mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-01 12:23:42 +02:00
2701 lines
84 KiB
ObjectPascal
2701 lines
84 KiB
ObjectPascal
unit girpascalwritertypes;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, girNameSpaces, girObjects, girTokens, contnrs, StrUtils;
|
|
|
|
type
|
|
TgirOption = (goWantTest, goLinkDynamic, goSeperateConsts, goClasses, goObjects, goIncludeDeprecated, goNoWrappers,
|
|
goEnumAsIntConst, goEnumAsTypedIntConst, goEnumAsIntAliasConst, goEnumAsEnum, goEnumAsSet
|
|
);
|
|
TgirOptions = set of TgirOption;
|
|
TgirWriteEvent = procedure (Sender: TObject; AUnitName: AnsiString; AStream: TStringStream) of object;
|
|
TgirEnumImpl = goEnumAsIntConst..goEnumAsSet;
|
|
|
|
TPDeclaration = class
|
|
function AsString: String; virtual; abstract;
|
|
end;
|
|
|
|
{ TPDeclarationWithLines }
|
|
|
|
TPDeclarationWithLines = class(TPDeclaration)
|
|
Lines: TStringList;
|
|
constructor Create; virtual;
|
|
destructor Destroy; override;
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
{ TPDeclarationType }
|
|
|
|
TPDeclarationType = class(TPDeclarationWithLines)
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
{ TPDeclarationConst }
|
|
|
|
TPDeclarationConst = class(TPDeclarationWithLines)
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
{ TPDeclarationEnumTypes }
|
|
|
|
TPDeclarationEnumTypes = class(TPDeclarationWithLines)
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
{ TPDeclarationVar }
|
|
|
|
TPDeclarationVar = class(TPDeclarationWithLines)
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
{ TPDeclarationFunctions }
|
|
|
|
TPDeclarationFunctions = class(TPDeclarationWithLines)
|
|
private
|
|
FDynamicFunctions: Boolean;
|
|
public
|
|
constructor Create(ADynamicFunctions: Boolean); reintroduce;
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
{ TPUses }
|
|
|
|
TPUses = class(TPDeclaration)
|
|
Units: TStringList;
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
|
|
|
|
{ TPDeclarationList }
|
|
|
|
TPDeclarationList = class(TList)
|
|
private
|
|
function GetDeclarations(AIndex: Integer): TPDeclaration;
|
|
public
|
|
function AsString: String;
|
|
property Declarations[AIndex: Integer]: TPDeclaration read GetDeclarations;
|
|
end;
|
|
|
|
{ TPUnitPart }
|
|
|
|
TPUnitPart = class
|
|
FOwner: TObject;
|
|
constructor Create(AOwner: TObject); virtual;
|
|
function AsString: String; virtual ; abstract;
|
|
end;
|
|
|
|
{ TPCommonSections }
|
|
|
|
TPCommonSections = class(TPUnitPart)
|
|
private
|
|
FDeclarations: TPDeclarationList;
|
|
public
|
|
constructor Create(AOwner: TObject); override;
|
|
destructor Destroy; override;
|
|
property Declarations: TPDeclarationList read FDeclarations;
|
|
end;
|
|
{ TPCodeText }
|
|
|
|
TPCodeText = class(TPDeclarationWithLines)
|
|
private
|
|
function GetContent: String;
|
|
procedure SetContent(AValue: String);
|
|
public
|
|
property Content: String read GetContent write SetContent;
|
|
end;
|
|
|
|
|
|
{ TPInterface }
|
|
|
|
TPInterface = class(TPCommonSections)
|
|
private
|
|
FConstSection: TPDeclarationConst;
|
|
FEnumTypesSection: TPDeclarationEnumTypes;
|
|
FFunctionSection: TPDeclarationFunctions;
|
|
FUsesSection: TPUses;
|
|
public
|
|
constructor Create(AOwner: TObject; AUses: TPUses; ADynamicFunctions: Boolean); reintroduce;
|
|
destructor Destroy; override;
|
|
function AsString: String; override;
|
|
property UsesSection: TPUses read FUsesSection;
|
|
property ConstSection: TPDeclarationConst read FConstSection;
|
|
property EnumTypesSection: TPDeclarationEnumTypes read FEnumTypesSection;
|
|
property FunctionSection: TPDeclarationFunctions read FFunctionSection;
|
|
end;
|
|
|
|
{ TPImplementation }
|
|
|
|
TPImplementation = class(TPCommonSections)
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
{ TPInitialize }
|
|
|
|
TPInitialize = class(TPCommonSections)
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
{ TPFinialization }
|
|
|
|
TPFinialization = class(TPCommonSections)
|
|
function AsString: String; override;
|
|
end;
|
|
|
|
TPascalUnit = class;
|
|
TPascalUnitType = (utSimple, utConsts, utTypes, utFunctions, utObjects, utClasses);
|
|
|
|
TPascalUnitTypes = set of TPascalUnitType;
|
|
const
|
|
PascalUnitTypeAll = [utSimple, utConsts, utTypes, utFunctions, utObjects, utClasses];
|
|
PascalUnitTypeCommon = [utConsts, utTypes, utFunctions];
|
|
type
|
|
{ TPascalUnitGroup }
|
|
|
|
TPascalUnitGroup = class
|
|
private
|
|
FSimpleUnit: Boolean;
|
|
FOptions: TgirOptions;
|
|
FNameSpace: TgirNamespace;
|
|
FUnitPrefix: String;
|
|
FWriter: TObject;//girPascalWriter;
|
|
FUnits: TFPList;
|
|
function GetUnitForType(AType: TPascalUnitType): TPascalUnit;
|
|
public
|
|
constructor Create(AWriter: TObject{TgirPascalWriter}; ANameSpace: TgirNamespace; AOptions: TgirOptions; AUnitPrefix: String);
|
|
destructor Destroy; override;
|
|
procedure GenerateUnits;
|
|
property UnitForType[AType: TPascalUnitType]: TPascalUnit read GetUnitForType;
|
|
end;
|
|
|
|
|
|
{ TPascalUnit }
|
|
|
|
TPascalUnit = class
|
|
private
|
|
FDynamicLoadUnloadSection: TPCodeText;
|
|
FDynamicEntryNames: TStringList;
|
|
FUnitPrefix: String;
|
|
FGroup : TPascalUnitGroup;
|
|
FOptions: TgirOptions;
|
|
FFinalizeSection: TPFinialization;
|
|
FImplementationSection: TPImplementation;
|
|
FInitializeSection: TPInitialize;
|
|
FInterfaceSection: TPInterface;
|
|
FLibName: String;
|
|
FUnitType: TPascalUnitTypes;
|
|
FNameSpace: TgirNamespace;
|
|
|
|
ProcessLevel: Integer; //used to know if to write forward definitions
|
|
//FTestCFile: TStringStream;
|
|
FTestPascalFile: TStringStream;
|
|
FTestPascalBody: TStringList;
|
|
function GetUnitFileName: String;
|
|
function GetUnitName: String;
|
|
function GetUnitPostfix: String;
|
|
function UnitPrefix: String;
|
|
|
|
function cExternal(const cName: String = ''): String;
|
|
|
|
// functions to ensure the type is being written in the correct declaration
|
|
function WantTypeSection: TPDeclarationType;
|
|
function WantConstSection: TPDeclarationConst;
|
|
function WantEnumTypesSection: TPDeclarationEnumTypes;
|
|
function WantFunctionSection: TPDeclarationFunctions;
|
|
// function WantVarSection: TPDeclarationVar;
|
|
|
|
// to process main language types
|
|
procedure HandleNativeType(AItem: TgirNativeTypeDef);
|
|
procedure HandleAlias(AItem: TgirAlias);
|
|
procedure HandleCallback(AItem: TgirCallback);
|
|
procedure HandleEnum(AItem: TgirEnumeration);
|
|
procedure HandleBitfield(AItem: TgirBitField);
|
|
procedure HandleRecord(AItem: TgirRecord);
|
|
procedure HandleOpaqueType(AItem: TgirFuzzyType);
|
|
procedure HandleFunction(AItem: TgirFunction);
|
|
procedure HandleObject(AItem: TgirObject; AObjectType: TGirToken);
|
|
procedure HandleUnion(AItem: TgirUnion);
|
|
|
|
procedure WriteForwardDefinition(AType: TGirBaseType);
|
|
|
|
|
|
//functions to write reused parts of types
|
|
procedure WriteWrapperForObject(ARoutineType, AObjectName, AObjectFunctionName: String; AParams:TgirParamList; AFunctionReturns: String; AFlatFunctionName: String; AWantSelf: Boolean);
|
|
function WriteCallBack(AItem: TgirFunction; IsInObject: Boolean; AExistingUsedNames: TStringList = nil): String;
|
|
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(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;
|
|
// methods for writing dynamic load code and libray names
|
|
procedure WriteDynamicLoadUnloadProcs;
|
|
function GetLibs: TStringList;
|
|
|
|
|
|
// methods for dealing with type names
|
|
function SanitizeName(AName: String; AExistingUsedNames: TStringList = nil): String;
|
|
procedure WritePointerTypesForType(AItem: TGirBaseType; ATypeName: String; APointerLevel: Integer; ALines: TStrings);
|
|
function TypeAsString(AType: TGirBaseType; APointerLevel: Integer; ACTypeAsBackup: String = ''): String;
|
|
procedure AssembleUsedFieldNamesFromParent(const AParent: TgirClass; var AUsedNamesList: TStringList);
|
|
|
|
procedure ResolveTypeTranslation(ABaseType: TGirBaseType);
|
|
function MakePascalTypeFromCType(CName: String; PointerLevel: Integer = MaxInt; Trim_T_IfExists: Boolean =True): String;
|
|
|
|
function EscapeSingleQuote(AString: String): String;
|
|
|
|
procedure AddGLibSupportCode;
|
|
|
|
procedure ProcessType(AType: TGirBaseType; AForceWrite: Boolean = False);
|
|
procedure ResolveFuzzyTypes;
|
|
procedure AddTestType(AGType: TgirGType);
|
|
public
|
|
constructor Create(AGroup: TPascalUnitGroup; ANameSpace: TgirNamespace; AOptions: TgirOptions; AUnitType: TPascalUnitTypes; AUnitPrefix: String);
|
|
destructor Destroy; override;
|
|
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;
|
|
function AsStream: TStringStream;
|
|
procedure Finish;
|
|
|
|
property InterfaceSection: TPInterface read FInterfaceSection;
|
|
property ImplementationSection: TPImplementation read FImplementationSection;
|
|
property DynamicLoadUnloadSection: TPCodeText read FDynamicLoadUnloadSection;
|
|
property InitializeSection: TPInitialize read FInitializeSection;
|
|
property FinalizeSection: TPFinialization read FFinalizeSection;
|
|
property UnitTypes: TPascalUnitTypes read FUnitType;
|
|
property UnitName: String read GetUnitName;
|
|
property UnitFileName: String read GetUnitFileName; // does not include the extension!
|
|
property LibName: String read FLibName write FLibName;
|
|
property NameSpace: TgirNamespace read FNameSpace;
|
|
end;
|
|
|
|
implementation
|
|
uses girpascalwriter, girCTypesMapping, girErrors, typinfo;
|
|
|
|
function IndentText(const AText: String; Spaces: Integer = 0; LineEndingCount: Integer = 1): String;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if AText = '' then
|
|
Exit('');
|
|
SetLength(Result, Spaces);
|
|
FillChar(Result[1], Spaces, ' ');
|
|
Result := Result+AText;
|
|
for i := 1 to LineEndingCount do
|
|
Result := Result+LineEnding;
|
|
end;
|
|
|
|
function MakePointerTypesForType(const AName: String; PointerLevel: Integer): TStringList;
|
|
var
|
|
//Chars: String;
|
|
BaseName: String;
|
|
i: Integer;
|
|
begin
|
|
Result := TStringList.Create;
|
|
if AName = '' then
|
|
Exit;
|
|
BaseName:=AName;
|
|
// check if it's already prefixed
|
|
if AName[1] = 'T' then
|
|
BaseName:=Copy(AName,2, Length(AName));
|
|
|
|
for i := 0 to PointerLevel-1 do
|
|
begin
|
|
BaseName := 'P'+BaseName;
|
|
Result.Add(BaseName);
|
|
end;
|
|
end;
|
|
|
|
function CalculateUnitName(ANameSpace: String; AVersion: String): String;
|
|
var
|
|
Version: String;
|
|
begin
|
|
if ANameSpace[Length(ANameSpace)] in ['0'..'9'] then
|
|
ANameSpace := ANameSpace + '_';
|
|
Version := StringReplace(AVersion,'.','_',[rfReplaceAll]);
|
|
Version := StringReplace(Version,'_0','',[rfReplaceAll]);
|
|
Result := ANameSpace+Version;
|
|
end;
|
|
|
|
{ TPDeclarationEnumTypes }
|
|
|
|
function TPDeclarationEnumTypes.AsString: String;
|
|
begin
|
|
if Lines.Count > 0 then begin
|
|
Result := IndentText('type') + Lines.Text;
|
|
end else begin
|
|
Result := '';
|
|
end;
|
|
end;
|
|
|
|
{ TPascalUnitGroup }
|
|
|
|
function TPascalUnitGroup.GetUnitForType(AType: TPascalUnitType): TPascalUnit;
|
|
var
|
|
PUnit: TPascalUnit;
|
|
begin
|
|
Result := nil;
|
|
for Pointer(PUnit) in FUnits do
|
|
if AType in PUnit.UnitTypes then
|
|
Exit(PUnit);
|
|
end;
|
|
|
|
constructor TPascalUnitGroup.Create(AWriter:TObject{TgirPascalWriter}; ANameSpace: TgirNamespace;
|
|
AOptions: TgirOptions; AUnitPrefix: String);
|
|
begin
|
|
FWriter := AWriter;
|
|
FNameSpace := ANameSpace;
|
|
FOptions := AOptions;
|
|
FUnits := TFPList.Create;
|
|
FUnitPrefix:=AUnitPrefix;
|
|
FSimpleUnit := ([goSeperateConsts, goClasses, goObjects] * AOptions ) = [];
|
|
FUnitPrefix:=AUnitPrefix;
|
|
|
|
if FSimpleUnit then
|
|
begin
|
|
FUnits.Add(TPascalUnit.Create(Self, FNameSpace, FOptions, PascalUnitTypeAll, FUnitPrefix));
|
|
//Units[utSimple] := TPascalUnit.Create(Self, FNameSpace, FOptions, [utSimple])
|
|
|
|
end
|
|
else
|
|
begin
|
|
//Units[utConsts] := TPascalUnit.Create(Self, FNameSpace, FOptions, [utConsts]);
|
|
//Units[utTypes] := TPascalUnit.Create(Self, FNameSpace, FOptions, [utTypes]);
|
|
//Units[utFunctions] := TPascalUnit.Create(Self, FNameSpace, FOptions, [utFunctions]);
|
|
FUnits.Add(TPascalUnit.Create(Self, FNameSpace, FOptions, PascalUnitTypeCommon, FUnitPrefix));
|
|
if goClasses in FOptions then
|
|
FUnits.Add(TPascalUnit.Create(Self, FNameSpace, FOptions, [utClasses], FUnitPrefix))
|
|
else
|
|
FUnits.Add(TPascalUnit.Create(Self, FNameSpace, FOptions, [utObjects], FUnitPrefix))
|
|
end;
|
|
|
|
end;
|
|
|
|
destructor TPascalUnitGroup.Destroy;
|
|
var
|
|
PascalUnit: TPascalUnit;
|
|
begin
|
|
for Pointer(PascalUnit) in FUnits do
|
|
if Assigned(PascalUnit) then
|
|
PascalUnit.Free;
|
|
FUnits.Free;
|
|
|
|
inherited Destroy;
|
|
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;
|
|
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
|
|
if Assigned(PUnit) then
|
|
begin
|
|
PUnit.Finish;
|
|
TgirPascalWriter(FWriter).OnUnitWriteEvent(TgirPascalWriter(FWriter), PUnit.UnitFileName+TgirPascalWriter(FWriter).DefaultUnitExtension, PUnit.AsStream);
|
|
TgirPascalWriter(FWriter).Units.Add(PUnit);
|
|
if (goWantTest in FOptions) then
|
|
begin
|
|
TgirPascalWriter(FWriter).OnUnitWriteEvent(TgirPascalWriter(FWriter), PUnit.UnitFileName+'_test'+TgirPascalWriter(FWriter).DefaultUnitExtension, PUnit.FTestPascalFile);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
constructor TPDeclarationFunctions.Create(ADynamicFunctions: Boolean);
|
|
begin
|
|
inherited Create;
|
|
FDynamicFunctions:=ADynamicFunctions;
|
|
Lines.Duplicates:=dupIgnore;
|
|
Lines.Sorted:=True;
|
|
end;
|
|
|
|
function TPDeclarationFunctions.AsString: String;
|
|
begin
|
|
if FDynamicFunctions then
|
|
Result := 'var'+ LineEnding+inherited AsString
|
|
else
|
|
Result:= inherited AsString;
|
|
end;
|
|
|
|
{ TPDeclarationVar }
|
|
|
|
function TPDeclarationVar.AsString: String;
|
|
begin
|
|
Result:= IndentText('var') + Lines.Text;
|
|
end;
|
|
|
|
{ TPDeclarationWithLines }
|
|
|
|
constructor TPDeclarationWithLines.Create;
|
|
begin
|
|
Lines := TStringList.Create;
|
|
end;
|
|
|
|
destructor TPDeclarationWithLines.Destroy;
|
|
begin
|
|
Lines.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TPDeclarationWithLines.AsString: String;
|
|
begin
|
|
Result:=Lines.Text;
|
|
end;
|
|
|
|
function TPCodeText.GetContent: String;
|
|
begin
|
|
Result := Lines.Text;
|
|
end;
|
|
|
|
procedure TPCodeText.SetContent(AValue: String);
|
|
begin
|
|
Lines.Text:=AValue;
|
|
end;
|
|
|
|
{ TPDeclarationType }
|
|
|
|
function TPDeclarationType.AsString: String;
|
|
begin
|
|
Result:= IndentText('type') + Lines.Text;
|
|
end;
|
|
|
|
{ TPDeclarationConst }
|
|
|
|
function TPDeclarationConst.AsString: String;
|
|
var
|
|
FirstConst: String;
|
|
begin
|
|
if Lines.Count < 1 then
|
|
Exit('');
|
|
if (Lines.count > 1) and (Lines[1] = 'type') then
|
|
FirstConst := ''
|
|
else
|
|
FirstConst:=IndentText('const');
|
|
|
|
Result:= FirstConst + Lines.Text;
|
|
end;
|
|
|
|
{ TPUses }
|
|
|
|
constructor TPUses.Create;
|
|
begin
|
|
Units := TStringList.Create;
|
|
Units.StrictDelimiter:=True;
|
|
Units.Delimiter:=',';
|
|
end;
|
|
|
|
destructor TPUses.Destroy;
|
|
begin
|
|
Units.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TPUses.AsString: String;
|
|
begin
|
|
Result := '';
|
|
|
|
if Units.Count>0 then
|
|
Result := IndentText('uses') + IndentText(Units.DelimitedText+';', 2)+LineEnding;
|
|
end;
|
|
|
|
{ TPFinialization }
|
|
|
|
function TPFinialization.AsString: String;
|
|
begin
|
|
Result := 'finalization'+LineEnding+FDeclarations.AsString;
|
|
end;
|
|
|
|
{ TPInitialize }
|
|
|
|
function TPInitialize.AsString: String;
|
|
begin
|
|
Result := 'initialization'+LineEnding+FDeclarations.AsString;
|
|
end;
|
|
|
|
function TPImplementation.AsString: String;
|
|
begin
|
|
Result := IndentText('implementation')+FDeclarations.AsString;
|
|
end;
|
|
|
|
{ TPCommonSections }
|
|
|
|
constructor TPCommonSections.Create(AOwner: TObject);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FDeclarations := TPDeclarationList.Create;
|
|
end;
|
|
|
|
destructor TPCommonSections.Destroy;
|
|
begin
|
|
FDeclarations.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
constructor TPInterface.Create(AOwner: TObject; AUses: TPUses; ADynamicFunctions: Boolean);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FUsesSection := AUses;
|
|
FUsesSection.Units.Add('CTypes');
|
|
FConstSection := TPDeclarationConst.Create;
|
|
FEnumTypesSection := TPDeclarationEnumTypes.Create;
|
|
FFunctionSection := TPDeclarationFunctions.Create(ADynamicFunctions);
|
|
end;
|
|
|
|
destructor TPInterface.Destroy;
|
|
begin
|
|
FConstSection.Free;
|
|
FFunctionSection.Free;
|
|
FUsesSection.Free;
|
|
inherited Destroy;
|
|
|
|
end;
|
|
|
|
function TPInterface.AsString: String;
|
|
begin
|
|
Result := IndentText('interface')+
|
|
FUsesSection.AsString+
|
|
FConstSection.AsString+
|
|
FEnumTypesSection.AsString +
|
|
FDeclarations.AsString+
|
|
FFunctionSection.AsString;
|
|
end;
|
|
|
|
{ TPUnitPart }
|
|
|
|
constructor TPUnitPart.Create(AOwner: TObject);
|
|
begin
|
|
FOwner := AOwner;
|
|
end;
|
|
|
|
{ TPascalUnit }
|
|
|
|
function TPascalUnit.GetUnitName: String;
|
|
begin
|
|
Result := FGroup.FUnitPrefix + CalculateUnitName(FNameSpace.NameSpace, FNameSpace.Version.AsString);
|
|
end;
|
|
|
|
function TPascalUnit.GetUnitFileName: String;
|
|
begin
|
|
Result := {UnitPrefix+}UnitName+GetUnitPostfix;
|
|
end;
|
|
|
|
function TPascalUnit.GetUnitPostfix: String;
|
|
begin
|
|
Result := '';
|
|
if FUnitType = PascalUnitTypeAll then
|
|
exit;
|
|
|
|
if PascalUnitTypeCommon = FUnitType then
|
|
Result := 'Common'
|
|
else if utClasses in FUnitType then
|
|
Result := 'Classes'
|
|
else if utObjects in FUnitType then
|
|
Result := 'Objects'
|
|
else
|
|
Result := 'UnknownPostfixName';
|
|
|
|
|
|
{case FUnitType of
|
|
utConsts: Result := 'Consts';
|
|
utTypes: Result := 'Types';
|
|
utFunctions: Result := 'Functions';
|
|
utClasses: Result := 'Classes';
|
|
utObjects: Result := 'Objects';
|
|
end;}
|
|
end;
|
|
|
|
function TPascalUnit.MakePascalTypeFromCType(CName: String; PointerLevel: Integer = MaxInt; Trim_T_IfExists: Boolean =True): String;
|
|
var
|
|
C: Integer = 0;
|
|
i: Integer = 0;
|
|
Prefix: String;
|
|
begin
|
|
Result := '';
|
|
|
|
repeat
|
|
i := Pos('*', CName);
|
|
if i > 0 then
|
|
begin
|
|
Inc(C);
|
|
Delete(CName, i,1);
|
|
end;
|
|
until i = 0;
|
|
|
|
if Trim_T_IfExists and (Length(CName) > 0) and (CName[1] = 'T') then
|
|
Delete(CName,1,1);
|
|
|
|
case PointerLevel of
|
|
MaxInt:; // C remains the same
|
|
-1: ;
|
|
0: C := 0;
|
|
else
|
|
C := PointerLevel;
|
|
end;
|
|
|
|
if C = -1 then
|
|
Prefix := ''
|
|
else if C = 0 then
|
|
Prefix := 'T'
|
|
else
|
|
begin
|
|
SetLength(Prefix, C);
|
|
FillChar(Prefix[1], C, 'P');
|
|
end;
|
|
Result := Trim(Prefix+Trim(CName));
|
|
end;
|
|
|
|
function TPascalUnit.EscapeSingleQuote(AString: String): String;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := AString;
|
|
for i := Length(Result) downto 1 do
|
|
if Result[i] = '''' then
|
|
Insert('''', Result, i);
|
|
end;
|
|
|
|
procedure TPascalUnit.AddGLibSupportCode;
|
|
var
|
|
TypeSect: TPDeclarationType;
|
|
i: Integer;
|
|
begin
|
|
//if not (FUnitType in [utSimple,utTypes]) then
|
|
// Exit;
|
|
if not ((FUnitType = PascalUnitTypeAll) or (utTypes in FUnitType )) then
|
|
Exit;
|
|
TypeSect := WantTypeSection;
|
|
for i := 1 to 31 do
|
|
begin
|
|
if i in [8,16,32] then
|
|
continue;
|
|
TypeSect.Lines.Add(Format(' guint%d = 0..(1 shl %d-1);',[i,i]));
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TPascalUnit.ProcessType(AType: TGirBaseType; AForceWrite: Boolean = False);
|
|
begin
|
|
if (AType = nil) then
|
|
Exit;
|
|
|
|
if (AType.ObjectType = otFuzzyType) and (TgirFuzzyType(AType).ResolvedType <> nil) then
|
|
begin
|
|
TgirFuzzyType(AType).ResolvedType.ImpliedPointerLevel := AType.ImpliedPointerLevel;
|
|
AType := TgirFuzzyType(AType).ResolvedType;
|
|
end;
|
|
|
|
if (AType.Owner <> FNameSpace) then
|
|
Exit; // it's written in another Namespace
|
|
|
|
if (AType.CType = '') then //(AType.Name = '') then
|
|
begin
|
|
//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
|
|
Exit;
|
|
end;
|
|
if (AType.Writing = msWritten) or ((AType.Writing = msWriting) {and not AForceWrite}) then
|
|
begin
|
|
//WriteLn('Already Written Type Used: ', AType.TranslatedName);
|
|
Exit;
|
|
end;
|
|
|
|
|
|
if not MeetsVersionConstraints(AType) then
|
|
Exit;
|
|
|
|
//if AForceWrite then
|
|
// WriteLn('ForceWriting: ', AType.CType);
|
|
|
|
Inc(ProcessLevel);
|
|
AType.Writing := msWriting;
|
|
|
|
case AType.ObjectType of
|
|
otAlias: HandleAlias(TgirAlias(AType));
|
|
otCallback: HandleCallback(TgirCallback(AType));
|
|
otEnumeration: HandleEnum(TgirEnumeration(AType));
|
|
otBitfield: HandleBitfield(TgirBitField(AType));
|
|
otRecord: HandleRecord(TgirRecord(AType));
|
|
otFunction: HandleFunction(TgirFunction(AType));
|
|
otGType: HandleObject(TgirGType(AType), gtGType);
|
|
otObject: HandleObject(TgirObject(AType), gtObject);
|
|
otClass: HandleObject(TgirObject(AType), gtClass);
|
|
otClassStruct: HandleObject(TgirObject(AType), gtClassStruct);
|
|
otNativeType: HandleNativeType(TgirNativeTypeDef(AType)); // not called but the items are added to the list... where are they?
|
|
otInterface: HandleObject(TgirInterface(AType), gtInterface);
|
|
otUnion: HandleUnion(TgirUnion(AType));
|
|
otFuzzyType:
|
|
begin
|
|
if TgirFuzzyType(AType).ResolvedType = nil then
|
|
HandleOpaqueType(TgirFuzzyType(AType))
|
|
else
|
|
begin
|
|
Dec(ProcessLevel); // it should be level 0
|
|
ProcessType(TgirFuzzyType(AType).ResolvedType);
|
|
Inc(ProcessLevel);
|
|
end;
|
|
end;
|
|
else
|
|
//WantTypeSection.Lines.Add(IndentText(AType.ClassName + ' ' +AType.Name + ' ' + AType.CType ,2));
|
|
girError(geFatal, 'Type.Ctype undefined! : '+ Atype.Name);
|
|
Halt;
|
|
end; // case
|
|
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);
|
|
end;
|
|
|
|
procedure TPascalUnit.ResolveFuzzyTypes;
|
|
var
|
|
BaseType: TGirBaseType;
|
|
FuzzyType : TgirFuzzyType absolute BaseType;
|
|
i: Integer;
|
|
CTypesType: String;
|
|
begin
|
|
// here we wil try to find unresolved types that have compatible types in pascal.
|
|
// for instance xlib uses guint but does not depend on glib where that is defined, we will try to replace those with cuint from ctypes
|
|
for i := 0 to NameSpace.Types.Count-1 do
|
|
begin
|
|
BaseType := TGirBaseType(NameSpace.Types.Items[i]);
|
|
if BaseType.InheritsFrom(TgirFuzzyType) and (FuzzyType.ResolvedType = nil) then
|
|
begin
|
|
if FuzzyType.CType = '' then begin
|
|
CTypesType := LookupGTypeToCType(FuzzyType.Name);
|
|
end else begin
|
|
CTypesType := LookupGTypeToCType(FuzzyType.CType);
|
|
end;
|
|
if CTypesType <> '' then
|
|
begin
|
|
FuzzyType.TranslatedName:= CTypesType;
|
|
//FuzzyType.TranslatedName:= FNameSpace.CPrefix + FuzzyType.Name;
|
|
FuzzyType.Writing := msWritten;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TPascalUnit.AddTestType(AGType: TgirGType);
|
|
const
|
|
PTest = 'procedure Test_%s;' +LineEnding+
|
|
'var' +LineEnding+
|
|
' PSize: Integer;' +LineEnding+
|
|
' CSize: Integer;' +LineEnding+
|
|
' CClassSize: Integer;' +LineEnding+
|
|
'begin' +LineEnding+
|
|
' PSize := SizeOf(%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+
|
|
'%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
|
|
PT: String;
|
|
PT2: String = '';
|
|
Cls: TgirClass absolute AGType;
|
|
begin
|
|
if not (goWantTest in FOptions) then
|
|
Exit;
|
|
if (AGType.CType = '') then //or (ACName[1] = '_') then // we skip private types
|
|
Exit;
|
|
ResolveTypeTranslation(AGType);
|
|
|
|
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]);
|
|
|
|
FTestPascalFile.WriteString(PT); // pascal testproc
|
|
FTestPascalBody.Add(Format('Test_%s;',[AGType.CType])); //call pascal testproc
|
|
end;
|
|
|
|
function TPascalUnit.UnitPrefix: String;
|
|
begin
|
|
Result := FUnitPrefix;
|
|
end;
|
|
|
|
function TPascalUnit.cExternal(const cName: String = ''): String;
|
|
begin
|
|
Result := ' external ' + UnitName + '_library';
|
|
if cName <> '' then begin
|
|
Result += ' name ''' + cName + '''';
|
|
end;
|
|
Result += ';';
|
|
end;
|
|
|
|
function TPascalUnit.WantTypeSection: TPDeclarationType;
|
|
begin
|
|
if (InterfaceSection.Declarations.Count = 0)
|
|
or (InterfaceSection.Declarations.Declarations[InterfaceSection.Declarations.Count-1].ClassType <> TPDeclarationType.ClassType)
|
|
then
|
|
begin
|
|
Result := TPDeclarationType.Create;
|
|
InterfaceSection.Declarations.Add(Result);
|
|
end
|
|
else
|
|
Result := TPDeclarationType(InterfaceSection.Declarations.Declarations[InterfaceSection.Declarations.Count-1]);
|
|
end;
|
|
|
|
function TPascalUnit.WantConstSection: TPDeclarationConst;
|
|
begin
|
|
Result := InterfaceSection.ConstSection;
|
|
end;
|
|
|
|
function TPascalUnit.WantEnumTypesSection: TPDeclarationEnumTypes;
|
|
begin
|
|
Result := InterfaceSection.EnumTypesSection;
|
|
end;
|
|
|
|
function TPascalUnit.WantFunctionSection: TPDeclarationFunctions;
|
|
begin
|
|
Result := InterfaceSection.FunctionSection;
|
|
end;
|
|
|
|
procedure TPascalUnit.WritePointerTypesForType(AItem: TGirBaseType; ATypeName: String; APointerLevel: Integer; ALines: TStrings);
|
|
var
|
|
PTypes: TStrings;
|
|
i: Integer;
|
|
begin
|
|
if AItem.ForwardDefinitionWritten then
|
|
girError(geWarn, 'Forwards definitions already written for : '+ Aitem.TranslatedName);
|
|
//WriteLn('Warning: Forwards definitions already written for : ', Aitem.TranslatedName);
|
|
AItem.ForwardDefinitionWritten := True;
|
|
PTypes := MakePointerTypesForType(ATypeName, APointerLevel);
|
|
ALines.Add('');
|
|
Alines.Add(IndentText('{ ' + ATypeName + ' }', 2, 0));
|
|
PTypes.Insert(0, ATypeName);
|
|
for i := PTypes.Count-1 downto 1 do
|
|
ALines.Add(IndentText(PTypes[i]+ ' = ^'+PTypes[i-1]+';',2,0));
|
|
PTypes.Free;
|
|
end;
|
|
|
|
procedure TPascalUnit.HandleNativeType(AItem: TgirNativeTypeDef);
|
|
var
|
|
TypeSect: TPDeclarationType;
|
|
ProperUnit: TPascalUnit;
|
|
begin
|
|
ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
if ProperUnit <> Self then begin
|
|
ProperUnit.HandleNativeType(AItem);
|
|
Exit;
|
|
end;
|
|
if (AItem.PascalName = AItem.CType) and (AItem.Name <> 'file') then
|
|
Exit; // is a native pascal type plus a = a doesn't fly with the compiler
|
|
|
|
|
|
if AItem.CType <> 'file' then
|
|
AItem.CType:=SanitizeName(AItem.CType);
|
|
|
|
TypeSect := WantTypeSection;
|
|
AItem.TranslatedName:=AItem.CType;
|
|
WritePointerTypesForType(Aitem, AItem.CType, AItem.ImpliedPointerLevel, TypeSect.Lines);
|
|
if AItem.Name <> 'file' then
|
|
TypeSect.Lines.Add(IndentText(SanitizeName(AItem.CType)+ ' = '+ AItem.PascalName+';', 2,0));
|
|
end;
|
|
|
|
procedure TPascalUnit.HandleAlias(AItem: TgirAlias);
|
|
var
|
|
ResolvedForName: String;
|
|
ProperUnit: TPascalUnit;
|
|
TargetType: TGirBaseType = nil;
|
|
begin
|
|
ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
if ProperUnit <> Self then begin
|
|
ProperUnit.HandleAlias(AItem);
|
|
Exit;
|
|
end;
|
|
ResolveTypeTranslation(AItem);
|
|
|
|
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 := TargetType.TranslatedName;
|
|
if ResolvedForName = '' then
|
|
begin
|
|
{
|
|
//CType := NameSpace.LookupTypeByName('', AItem.ForType.CType);
|
|
if CType <> nil then
|
|
ResolvedForName := CType.TranslatedName;
|
|
|
|
if ResolvedForName <> '' then
|
|
aItem.ForType.TranslatedName := ResolvedForName
|
|
else}
|
|
ResolvedForName := AItem.ForType.CType;
|
|
end;
|
|
|
|
WriteForwardDefinition(AItem);
|
|
|
|
AItem.TranslatedName:=MakePascalTypeFromCType(AItem.CType);
|
|
|
|
if AItem.IsOpaque then
|
|
HandleOpaqueType(TgirFuzzyType(TargetType))
|
|
else if AItem.Writing < msWritten then
|
|
WantTypeSection.Lines.Add(IndentText(Aitem.TranslatedName+' = '+ ResolvedForName+';' ,2,0));
|
|
end;
|
|
|
|
procedure TPascalUnit.HandleCallback(AItem: TgirCallback);
|
|
var
|
|
TypeSect: TPDeclarationType;
|
|
CB: String;
|
|
ProperUnit: TPascalUnit;
|
|
begin
|
|
ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
if ProperUnit <> Self then begin
|
|
ProperUnit.HandleCallback(AItem);
|
|
Exit;
|
|
end;
|
|
TypeSect := WantTypeSection;
|
|
|
|
CB := WriteCallBack(AItem, False);
|
|
|
|
if AItem.Writing < msWritten then
|
|
TypeSect.Lines.Add(IndentText(CB,2,0))
|
|
end;
|
|
|
|
function CompareEnumValues(v1, v2: Pointer): Integer;
|
|
begin
|
|
Result := StrToInt(PgirEnumMember(v1)^.Value) - StrToInt(PgirEnumMember(v2)^.Value);
|
|
end;
|
|
|
|
procedure TPascalUnit.HandleEnum(AItem: TgirEnumeration);
|
|
var
|
|
ConstSection: TPDeclarationConst;
|
|
Section: TPDeclarationWithLines;
|
|
Entry: String;
|
|
i: Integer;
|
|
CName: String;
|
|
TypeName: String;
|
|
ProperUnit: TPascalUnit;
|
|
IntType: String;
|
|
Value: String;
|
|
UIntValue: QWord;
|
|
MSB: Integer;
|
|
begin
|
|
ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
if ProperUnit <> Self then begin
|
|
ProperUnit.HandleEnum(AItem);
|
|
Exit;
|
|
end;
|
|
ResolveTypeTranslation(AItem);
|
|
|
|
ConstSection := WantConstSection;
|
|
if (goEnumAsSet in FOptions) and (AItem is TgirBitField) then begin
|
|
// forces forward declarations to be written
|
|
ProcessType(AItem);
|
|
TypeName := AItem.TranslatedName + 'Idx';
|
|
Section := WantEnumTypesSection;
|
|
Section.Lines.Add(IndentText(TypeName + ' = (', 2, 0));
|
|
Section.Lines.Add(IndentText(TypeName + 'MinValue = 0,', 4, 0));
|
|
AItem.Members.Sort(@CompareEnumValues)
|
|
end else if goEnumAsEnum in FOptions then begin
|
|
// forces forward declarations to be written
|
|
ProcessType(AItem);
|
|
TypeName := AItem.TranslatedName;
|
|
Section := WantEnumTypesSection;
|
|
Section.Lines.Add(IndentText(TypeName + ' = (', 2, 0));
|
|
Section.Lines.Add(IndentText(TypeName + 'MinValue = -$7FFFFFFF,', 4, 0));
|
|
AItem.Members.Sort(@CompareEnumValues)
|
|
end else if goEnumAsIntAliasConst in FOptions then begin
|
|
// forces forward declarations to be written
|
|
ProcessType(AItem);
|
|
TypeName := AItem.TranslatedName;
|
|
Section := WantConstSection;
|
|
Section.Lines.Add('');
|
|
Section.Lines.Add('type');
|
|
if AItem.NeedsSignedType then
|
|
IntType := 'Integer'
|
|
else
|
|
IntType := 'DWord';
|
|
// yes we cheat a little here using the const section to write type info
|
|
Section.Lines.Add(IndentText(TypeName + ' = type ' + IntType + ';', 2, 0));
|
|
Section.Lines.Add('const');
|
|
Section.Lines.Add(IndentText('{ '+ AItem.CType + ' }', 2, 0));
|
|
end else if goEnumAsTypedIntConst in FOptions then begin
|
|
// forces forward declarations to be written
|
|
ProcessType(AItem);
|
|
|
|
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('');
|
|
ConstSection.Lines.Add('type');
|
|
ConstSection.Lines.Add(IndentText(AItem.TranslatedName+' = '+IntType+';', 2,0));
|
|
ConstSection.Lines.Add('const');
|
|
ConstSection.Lines.Add(IndentText('{ '+ AItem.CType + ' }', 2, 0));
|
|
Section := ConstSection;
|
|
end else begin
|
|
TypeName:='';
|
|
ConstSection.Lines.Add(IndentText('{ '+ AItem.CType + ' }', 2, 0));
|
|
Section := ConstSection;
|
|
end;
|
|
|
|
for i := 0 to AItem.Members.Count-1 do
|
|
begin
|
|
CName := AItem.Members.Member[i]^.CIdentifier;
|
|
if CName = 'ATK_HYPERLINK_IS_INLINE' then
|
|
CName :='ATK_HYPERLINK_IS_INLINE_';
|
|
Value := AItem.Members.Member[i]^.Value;
|
|
if (goEnumAsSet in FOptions) and (AItem is TgirBitField) then begin
|
|
UIntValue := UInt64(StrToInt(Value));
|
|
if UIntValue = 0 then
|
|
Continue;
|
|
MSB := BsrQWord(UIntValue);
|
|
if UIntValue > 1 shl MSB then
|
|
Continue;
|
|
Value := IntToStr(MSB);
|
|
Entry := IndentText(CName + ' = ' + Value + ',', 4, 0);;
|
|
end else if goEnumAsEnum in FOptions then begin
|
|
Entry := IndentText(CName + ' = ' + Value + ',', 4, 0);
|
|
end else if goEnumAsIntAliasConst in FOptions then begin
|
|
Entry := IndentText(CName + ' = ' + TypeName + '(' + Value + ');', 2, 0);
|
|
end else if goEnumAsTypedIntConst in FOptions then begin
|
|
Entry := IndentText(CName + ': ' + TypeName + ' = ' + Value + ';', 2, 0);
|
|
end else begin
|
|
Entry := IndentText(CName + ' = ' + Value + ';', 2, 0);
|
|
end;
|
|
Section.Lines.Add(Entry);
|
|
end;
|
|
if (goEnumAsSet in FOptions) and (AItem is TgirBitField) then begin
|
|
Value := '31';
|
|
end else begin
|
|
Value := '$7FFFFFFF';
|
|
end;
|
|
if goEnumAsEnum in FOptions then begin
|
|
Section.Lines.Add(IndentText(TypeName + 'MaxValue = ' + Value, 4, 0));
|
|
Section.Lines.Add(IndentText(');', 2, 0));
|
|
end;
|
|
AItem.Writing:=msWritten;
|
|
end;
|
|
|
|
procedure TPascalUnit.HandleBitfield(AItem: TgirBitField);
|
|
function WriteSet(Name, TypeName: String; Value: Integer): String;
|
|
var
|
|
Comma: String[2];
|
|
n: Integer;
|
|
i: Integer;
|
|
StrValue: String;
|
|
begin
|
|
WriteLn(Name, ' = ', Value);
|
|
if Value = 0 then begin
|
|
Exit(IndentText(Name + ' = []; {0 = $00000000}', 2));
|
|
end;
|
|
Result := IndentText(Name + ' = [', 2, 0);
|
|
Comma := LineEnding;
|
|
for n := BsfDWord(Value) to BsrDword(Value) do begin
|
|
if Value and (1 << n) <> 0 then begin
|
|
StrValue := IntToStr(1 << n);
|
|
Name := TypeName + 'Idx(' + IntToStr(n) + ')';
|
|
for i := 0 to AItem.Members.Count - 1 do begin
|
|
if StrValue = AItem.Members.Member[i]^.Value then begin
|
|
Name := AItem.Members.Member[i]^.CIdentifier;
|
|
Break;
|
|
end;
|
|
end;
|
|
Result += Comma + IndentText(Name, 4, 0);
|
|
Comma := ',' + LineEnding;
|
|
end;
|
|
end;
|
|
Result += LineEnding;
|
|
Result += IndentText(']; {' + IntToStr(Value) + ' = $' + IntToHex(Value) + '}', 2);
|
|
end;
|
|
var
|
|
Section: TPDeclarationWithLines;
|
|
TypeName: String;
|
|
Name: String;
|
|
Value: String;
|
|
UIntValue: Integer;
|
|
MSB: Integer;
|
|
i: Integer;
|
|
AddedConst: Boolean;
|
|
begin
|
|
HandleEnum(AItem);
|
|
if goEnumAsSet in FOptions then begin
|
|
Section := WantEnumTypesSection;
|
|
TypeName := AItem.TranslatedName;
|
|
Section.Lines.Add(IndentText(TypeName + ' = Set of ' + TypeName + 'Idx;', 2, 0));
|
|
AddedConst := False;
|
|
for i := 0 to AItem.Members.Count-1 do begin
|
|
Name := AItem.Members.Member[i]^.CIdentifier;
|
|
Value := AItem.Members.Member[i]^.Value;
|
|
UIntValue := UInt64(StrToInt(Value));
|
|
MSB := BsrQWord(UIntValue);
|
|
if UIntValue > 1 shl MSB then begin
|
|
if not AddedConst then begin
|
|
Section.Lines.Add('const');
|
|
AddedConst := True;
|
|
end;
|
|
Section.Lines.Add(WriteSet(Name, TypeName, UIntValue));
|
|
end;
|
|
end;
|
|
if AddedConst then begin
|
|
Section.Lines.Add('type');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TPascalUnit.HandleRecord(AItem: TgirRecord);
|
|
var
|
|
ProperUnit: TPascalUnit;
|
|
begin
|
|
ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
if ProperUnit <> Self then begin
|
|
ProperUnit.HandleRecord(AItem);
|
|
Exit;
|
|
end;
|
|
ResolveTypeTranslation(AItem);
|
|
AItem.ImpliedPointerLevel:=1; // will not be decreased only will grow
|
|
|
|
WriteForwardDefinition(AItem);
|
|
|
|
WantTypeSection.Lines.Add(WriteRecord(AItem));
|
|
|
|
end;
|
|
|
|
procedure TPascalUnit.HandleOpaqueType(AItem: TgirFuzzyType);
|
|
var
|
|
TypeSect: TPDeclarationType;
|
|
Plain: String;
|
|
ProperUnit: TPascalUnit;
|
|
begin
|
|
ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
if ProperUnit <> Self then begin
|
|
ProperUnit.HandleOpaqueType(AItem);
|
|
Exit;
|
|
end;
|
|
if AItem.CType = '' then
|
|
Exit;
|
|
TypeSect := WantTypeSection;
|
|
Plain := StringReplace(AItem.CType, '*', '', [rfReplaceAll]);
|
|
AItem.TranslatedName:=MakePascalTypeFromCType(Plain, 0);
|
|
|
|
TypeSect.Lines.Add('');
|
|
TypeSect.Lines.Add(' { '+ AItem.CType+' }');
|
|
TypeSect.Lines.Add(IndentText(AItem.TranslatedName +' = record',2,0));
|
|
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));
|
|
girError(geInfo, 'Wrote Opaque Type Name = ' + AItem.Name +' CType = '+ AItem.CType);
|
|
|
|
end;
|
|
|
|
function HasPackedBitfield(var PackedBits: TStringList): Boolean;
|
|
begin
|
|
HasPackedBitfield := PackedBits <> nil;
|
|
end;
|
|
|
|
procedure PackedBitsAddEntry (var PackedBits: TStringList; AItem: TGirBaseType; var APackedBitsFieldCount: Integer; AEntry: String; AOriginalDeclList: TStrings); // creates a new type to hold the packed bits
|
|
const
|
|
BitType = ' %sBitfield%d = bitpacked record';
|
|
var
|
|
BitEntry: String;
|
|
begin
|
|
if PackedBits = nil then
|
|
begin
|
|
PackedBits := TStringList.Create;
|
|
PackedBits.Add(Format(BitType,[AItem.TranslatedName, APackedBitsFieldCount]));
|
|
BitEntry := Format(' Bitfield%d : %sBitfield%d; { auto generated type }', [APackedBitsFieldCount, AItem.TranslatedName, APackedBitsFieldCount]);
|
|
AOriginalDeclList.Add(BitEntry);
|
|
Inc(APackedBitsFieldCount);
|
|
end;
|
|
// now packed bits is assigned
|
|
PackedBits.Add(Format(' %s;', [AEntry]));
|
|
end;
|
|
|
|
function EndPackedBits(var PackedBits: TStringList): String;
|
|
begin
|
|
if PackedBits = nil then
|
|
Exit;
|
|
PackedBits.Add(' end;');
|
|
Result := PackedBits. Text;
|
|
FreeAndNil(PackedBits);
|
|
end;
|
|
|
|
|
|
|
|
|
|
procedure TPascalUnit.HandleFunction(AItem: TgirFunction);
|
|
var
|
|
RoutineType: String;
|
|
Returns: String;
|
|
Params: String;
|
|
FuncSect: TPDeclarationFunctions;
|
|
Postfix: String;
|
|
ProperUnit: TPascalUnit;
|
|
begin
|
|
ProperUnit := FGroup.GetUnitForType(utFunctions);
|
|
if ProperUnit <> Self then
|
|
begin
|
|
ProperUnit.HandleFunction(AItem);
|
|
Exit;
|
|
end;
|
|
|
|
if not MeetsVersionConstraints(AItem) then
|
|
Exit; // ==>
|
|
|
|
WriteFunctionTypeAndReturnType(AItem, RoutineType, Returns);
|
|
Params := WriteFunctionParams(AItem.Params);
|
|
Postfix := cExternal(AItem.CIdentifier);
|
|
FuncSect := WantFunctionSection;
|
|
if not (goLinkDynamic in FOptions) then
|
|
FuncSect.Lines.Add(RoutineType +' '+ AItem.CIdentifier+ParenParams(Params)+Returns+Postfix)
|
|
else
|
|
begin
|
|
FuncSect.Lines.Add(AItem.CIdentifier +': '+RoutineType +ParenParams(Params)+Returns);
|
|
FDynamicEntryNames.Add(AItem.CIdentifier);
|
|
end;
|
|
end;
|
|
|
|
function TPascalUnit.WriteFunction(AFunction: TgirFunction; AItem: TGirBaseType; AIsMethod: Boolean; AWantWrapperForObject: Boolean; AFunctionList: TStrings; AExistingUsedNames: TStringList = nil): String;
|
|
var
|
|
Prefix: String = '';
|
|
RoutineType: String;
|
|
Returns: String;
|
|
Params: String;
|
|
Postfix: String;
|
|
Entry: String;
|
|
InLineS: String = '';
|
|
DeprecatedS: String = '';
|
|
ProperUnit: TPascalUnit;
|
|
OptionsIndicateWrapperMethod: Boolean;
|
|
begin
|
|
{ I apologize to anyone who tries to figure all this out. In short this function
|
|
writes procedure lines for an object and it's implementation. As well as the
|
|
plain function the object method calls.
|
|
}
|
|
Result := '';
|
|
OptionsIndicateWrapperMethod:= FUnitType = PascalUnitTypeAll;
|
|
// we skip deprecated functions
|
|
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 :(
|
|
if (AFunction.CIdentifier = 'g_io_module_query')
|
|
or (AFunction.CIdentifier = 'g_io_module_load')
|
|
or (AFunction.CIdentifier = 'g_io_module_unload')
|
|
then
|
|
Exit; // they are functions to be implemented by a runtime loadable module, they are not actually functions in glib/gmodule/gio
|
|
|
|
if AWantWrapperForObject then
|
|
InLineS:=' inline;';
|
|
|
|
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);
|
|
|
|
// check if it is a constructor
|
|
if AFunction.InheritsFrom(TgirConstructor) then
|
|
Returns := ': '+MakePascalTypeFromCType(AItem.TranslatedName ,1)+'; cdecl;';
|
|
|
|
Params := WriteFunctionParams(AFunction.Params, nil, False);
|
|
if Pos('array of const', Params) + Pos('va_list', Params) > 0 then
|
|
Prefix:='//';
|
|
if not (goLinkDynamic in FOptions) then
|
|
Postfix := cExternal(AFunction.CIdentifier) + DeprecatedS
|
|
else
|
|
PostFix := ''+DeprecatedS;
|
|
|
|
// first wrapper proc
|
|
Entry := Prefix + RoutineType +' '+ SanitizeName(AFunction.Name, AExistingUsedNames)+ParenParams(Params)+Returns+InLineS;
|
|
|
|
// no need to pass self that will not be used
|
|
if (not AIsMethod) and AWantWrapperForObject then
|
|
Entry := Entry + ' static;';
|
|
|
|
// This is the line that will be used by in the TObject declaration. <----
|
|
// result will be written in the object declaration.
|
|
if OptionsIndicateWrapperMethod and not(goNoWrappers in FOptions) then
|
|
Result := Entry + DeprecatedS
|
|
else
|
|
Result := '';
|
|
|
|
// now make sure the flat proc has all the params it needs
|
|
if AIsMethod then
|
|
begin
|
|
// with older introspection versions methods do not include the first param for it's type so we have to add it
|
|
if (AFunction.Params.Count = 0) // <--only true if older
|
|
or ((AFunction.Params.Count > 0) and not(AFunction.Params.Param[0].IsInstanceParam)) then // <-- true if older
|
|
begin
|
|
if Params <> '' then
|
|
Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1)+'; ' + Params
|
|
else
|
|
Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1);
|
|
end
|
|
else
|
|
Params := WriteFunctionParams(AFunction.Params, nil, True);
|
|
end;
|
|
|
|
ProperUnit := FGroup.GetUnitForType(utFunctions);
|
|
|
|
// write the flat c function that will be linked
|
|
if not (goLinkDynamic in FOptions) then
|
|
begin
|
|
// this is the flat c procedure that a wrapper would call
|
|
Entry := RoutineType +' '+ AFunction.CIdentifier+ParenParams(Params)+Returns;
|
|
end
|
|
else // Link Dynamic
|
|
begin
|
|
Entry := AFunction.CIdentifier+': '+RoutineType+ParenParams(Params)+Returns;
|
|
ProperUnit.FDynamicEntryNames.Add(AFunction.CIdentifier);
|
|
end;
|
|
|
|
// ignores duplicates
|
|
AFunctionList.Add(Entry+Postfix);
|
|
|
|
//RoutineType, AObjectName, AObjectFunctionName, AParams, AFunctionReturns, AFlatFunctionName, AWantSelf
|
|
// writes the implementation of what we declared in the object
|
|
if AWantWrapperForObject and (Prefix = '') and OptionsIndicateWrapperMethod and not (goNoWrappers in FOptions) then
|
|
WriteWrapperForObject(RoutineType, AItem.TranslatedName, ProperUnit.SanitizeName(AFunction.Name), AFunction.Params, Returns, AFunction.CIdentifier, AIsMethod);
|
|
end;
|
|
|
|
procedure TPascalUnit.HandleObject(AItem: TgirObject; AObjectType: TGirToken);
|
|
var
|
|
TypeDecl: TStringList;
|
|
i: Integer;
|
|
UnitFuncs,
|
|
TypeFuncs: TStrings; // functions and procedures of an object
|
|
ParentType: String ='';
|
|
UsedNames: TStringList;
|
|
WrittenFields: Integer;
|
|
PackedBitsFieldCount: Integer = 0;
|
|
PackedBits: TStringList = nil;
|
|
|
|
function GetTypeForProperty(AProperty: TgirProperty; out SetFound: Boolean): String;
|
|
var
|
|
i,j: Integer;
|
|
FoundPos: Integer;
|
|
LookingForGet,
|
|
LookingForSet: String;
|
|
Line: String;
|
|
GetFound: Boolean;
|
|
begin
|
|
GetFound := False;
|
|
SetFound := False;
|
|
Result := 'UNABLE_TO_FIND_TYPE_FOR_PROPERTY';
|
|
LookingForGet:=SanitizeName('get_'+AProperty.Name);
|
|
LookingForSet:=SanitizeName('set_'+AProperty.Name);
|
|
for i := TypeFuncs.Count-1 downto 0 do
|
|
begin
|
|
Line := TypeFuncs.Strings[i];
|
|
|
|
if not GetFound then
|
|
begin
|
|
FoundPos:= Pos(LookingForGet+':', Line);
|
|
//if FoundPos = 0 then
|
|
// FoundPos:=Pos(LookingForGet+'(', Line); // we do not yet support properties with parameters :(
|
|
end;
|
|
if (FoundPos > 0) and not GetFound then
|
|
begin
|
|
GetFound := True;
|
|
for j := Length(Line) downto 1 do
|
|
if Line[j] = ':' then
|
|
begin
|
|
Line := Copy(Line, j+1, Length(Line));
|
|
break;
|
|
end;
|
|
FoundPos:=Pos(';', Line);
|
|
Result := Trim(Copy(Line, 1,FoundPos-1));
|
|
//WriteLn('Found property: ',Result, ' Property Value = ', AProperty.PropType.CType);
|
|
break;
|
|
end
|
|
end;
|
|
|
|
for i := TypeFuncs.Count-1 downto 0 do
|
|
begin
|
|
Line := TypeFuncs.Strings[i];
|
|
|
|
SetFound := Pos(LookingForSet+':', Line) > 0;
|
|
SetFound := SetFound or (Pos(LookingForSet+'(', Line) > 0);
|
|
|
|
// the first argument must match the property type! (result is the return type)
|
|
//if SetFound and (Pos(Result+')', Line) = 0) then
|
|
// writeln('Eliminated ', Line, ' for missing: ', Result);
|
|
SetFound := SetFound and (Pos(Result+')', Line) > 0);
|
|
|
|
// pascal properties cannot use functions for the set 'procedure'
|
|
SetFound := SetFound and (Pos('procedure ', Line) > 0) and (Pos('property '+AProperty.Name, Line) = 0);
|
|
|
|
if SetFound then
|
|
Exit;
|
|
end;
|
|
|
|
|
|
end;
|
|
function WriteMethodProperty(AProperty: TgirProperty; AType: String; SetFound: Boolean): String;
|
|
const
|
|
Prop = '%sproperty %s: %s %s %s;';
|
|
var
|
|
ReadFunc,
|
|
WriteProc: String;
|
|
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('');
|
|
ReadFunc:= 'read '+SanitizeName('get_'+ AProperty.Name);
|
|
if AProperty.Writable then
|
|
begin
|
|
if SetFound then
|
|
WriteProc := 'write '+ SanitizeName('set_'+AProperty.Name)
|
|
else
|
|
WriteProc := ' { property is writeable but setter not declared } ';
|
|
end;
|
|
if AType = 'UNABLE_TO_FIND_TYPE_FOR_PROPERTY' then
|
|
Comment := '//';
|
|
|
|
Result := Format(Prop, [Comment, SanitizeName(AProperty.Name, UsedNames), AType, ReadFunc, WriteProc ]);
|
|
end;
|
|
|
|
function AddField(AParam: TgirTypeParam): Boolean; // returns True if a bitsized param was used or false if it wasn't.
|
|
var
|
|
Param: String;
|
|
ParamIsBitSized: Boolean;
|
|
begin
|
|
ResolveTypeTranslation(AParam.VarType);
|
|
AddField := False;
|
|
|
|
// this is for object inheritance. a struct conatins the parent as the first field so we must remove it since our object inherits it already
|
|
Inc(WrittenFields);
|
|
if (WrittenFields = 1) and (AObjectType = gtClass) and (TgirClass(AItem).ParentClass <> nil) then
|
|
begin
|
|
Exit;
|
|
end;
|
|
|
|
Param := WriteParamAsString(AItem.name, AParam,i, ParamIsBitSized, nil, UsedNames);
|
|
|
|
if ParamIsBitSized then
|
|
PackedBitsAddEntry(PackedBits, AItem, PackedBitsFieldCount, Param, TypeDecl)
|
|
else
|
|
TypeDecl.Add(IndentText(Param+';',4,0));
|
|
AddField := ParamIsBitSized;
|
|
end;
|
|
|
|
procedure AddLinesIfSet(AList: TStrings; const TextIn: String);
|
|
begin
|
|
if Trim(TextIn) <> '' then
|
|
AList.Add(TextIn);
|
|
end;
|
|
|
|
procedure HandleFieldType(Field: TGirBaseType; AFirstPass: Boolean; out AddedBitSizedType: Boolean);
|
|
var
|
|
SetFound: Boolean;
|
|
PropType: String;
|
|
FieldName: 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,
|
|
otArray,
|
|
otTypeParam,
|
|
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 = gtInterface then // signals are external to the object and not 'part' of them
|
|
TypeDecl.Add(IndentText(WriteCallBack(TgirCallback(Field),True, UsedNames),4,0));
|
|
|
|
//WriteFunction(AFunction, AItem, AIsMethod, AWantWrapperForObject, AFunctionList): String;
|
|
otFunction : AddLinesIfSet(TypeFuncs, IndentText(WriteFunction(TgirFunction(Field), AItem, False, True, UnitFuncs, UsedNames),4,0));
|
|
otMethod : AddLinesIfSet(TypeFuncs, IndentText(WriteFunction(TgirFunction(Field), AItem, True, True, UnitFuncs, UsedNames),4,0));
|
|
otConstructor : AddLinesIfSet(TypeFuncs, IndentText(WriteFunction(TgirConstructor(Field), AItem, False, True, UnitFuncs, UsedNames),4,0));
|
|
otProperty :
|
|
begin
|
|
PropType := GetTypeForProperty(TgirProperty(Field), SetFound);
|
|
AddLinesIfSet(TypeFuncs, IndentText(WriteMethodProperty(TgirProperty(Field), PropType, SetFound),4,0));
|
|
end;
|
|
|
|
else // case <
|
|
girError(geFatal, 'Unknown Field Type : '+ Field.ClassName);
|
|
Halt;
|
|
end;
|
|
end;
|
|
|
|
// SECOND PASS
|
|
if not AFirstPass then
|
|
begin
|
|
case Field.ObjectType of
|
|
otArray,
|
|
otTypeParam: AddedBitSizedType := AddField(TgirTypeParam(Field));
|
|
otCallback : TypeDecl.Add(IndentText(WriteCallBack(TgirCallback(Field),True, UsedNames),4,0));
|
|
otUnion :
|
|
begin
|
|
// we have to create a union outside the object and include it as a field
|
|
Field.CType := AItem.CType+'_union_'+Field.Name;
|
|
ResolveTypeTranslation(Field);
|
|
HandleUnion(TgirUnion(Field));
|
|
FieldName := Field.Name;
|
|
if FieldName = '' then begin
|
|
FieldName := '__unnamed_field__' + Field.CType;
|
|
end;
|
|
TypeDecl.Add(IndentText(SanitizeName(FieldName, UsedNames)+': '+ Field.TranslatedName+'; //union extracted from object and named '''+Field.TranslatedName+'''',4,0));
|
|
end
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
function GetParentType(AClass: TgirClass): String;
|
|
begin
|
|
Result := '';
|
|
AssembleUsedFieldNamesFromParent(AClass.ParentClass, UsedNames);
|
|
if AClass.ParentClass = nil then
|
|
Exit;
|
|
if AClass.ParentClass.Writing < msWritten then
|
|
ProcessType(AClass.ParentClass, True); // this type must be first
|
|
|
|
Result := AClass.ParentClass.TranslatedName;
|
|
if Result = '' then
|
|
begin
|
|
WriteLn('Class has parent but name is empty! : ', AClass.CType);
|
|
WriteLn('Parent Name = ', AClass.ParentClass.Name);
|
|
WriteLn('Parent CType = ', AClass.ParentClass.CType);
|
|
WriteLn('Parent Translated Name = ', AClass.ParentClass.TranslatedName);
|
|
Halt
|
|
end;
|
|
end;
|
|
procedure AddGetTypeProc(AObj: TgirGType);
|
|
const
|
|
GetTypeTemplate = 'function %s: %s; cdecl;';
|
|
GetTypeTemplateDyn = '%s: function:%s; cdecl;';
|
|
var
|
|
AType: String;
|
|
AName : string;
|
|
begin
|
|
AType:='TGType';
|
|
if (AObj.GetTypeFunction = '') or (AObj.GetTypeFunction = 'none') or (AObj.GetTypeFunction = 'intern') then
|
|
Exit;
|
|
if not NameSpace.UsesGLib then
|
|
AType := 'csize_t { TGType }';
|
|
|
|
if not (goLinkDynamic in FOptions) then
|
|
begin
|
|
AName:=AObj.GetTypeFunction;
|
|
UnitFuncs.Add(Format(GetTypeTemplate, [AName, AType]) + cExternal(AName));
|
|
end
|
|
else
|
|
begin
|
|
UnitFuncs.Add(Format(GetTypeTemplateDyn, [AObj.GetTypeFunction, AType]));
|
|
FDynamicEntryNames.Add(AObj.GetTypeFunction);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
TypeSect: TPDeclarationType;
|
|
AddedBitSizedType: Boolean;
|
|
ProperUnit: TPascalUnit = nil;
|
|
begin
|
|
case AItem.ObjectType of
|
|
otObject: ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
otClassStruct: ProperUnit := FGroup.GetUnitForType(utTypes); //class structs go in types!
|
|
otInterface: ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
otGType: ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
otClass :
|
|
begin
|
|
if goClasses in FOptions then
|
|
ProperUnit := FGroup.GetUnitForType(utClasses)
|
|
else if goObjects in FOptions then
|
|
ProperUnit := FGroup.GetUnitForType(utObjects)
|
|
else
|
|
ProperUnit := Self;
|
|
end;
|
|
else
|
|
girError(geFatal, 'Unknown ObjectType : '+ GetEnumName(TypeInfo(TGirToken), Ord(AObjectType)));
|
|
Halt;
|
|
end;
|
|
if ProperUnit = nil then
|
|
begin
|
|
girError(geFatal, 'ProperUnit is not assigned! : '+ GetEnumName(TypeInfo(TGirToken), Ord(AObjectType)));
|
|
Halt;
|
|
end;
|
|
if ProperUnit <> Self then
|
|
begin
|
|
ProperUnit.HandleObject(AItem, AObjectType);
|
|
Exit;
|
|
end;
|
|
|
|
if AItem.CType = '' then
|
|
Exit;
|
|
// if any params use a type that is not written we must write it before we use it!!
|
|
TypeDecl := TStringList.Create;
|
|
UsedNAmes := TStringList.Create;
|
|
UsedNames.Sorted:=True;
|
|
UsedNames.Duplicates:=dupError;
|
|
ResolveTypeTranslation(AItem);
|
|
AItem.ImpliedPointerLevel:=1; //will only grow
|
|
|
|
// forces it to write forward declarations if they are not yet.
|
|
ProcessType(AItem);
|
|
|
|
UnitFuncs := TStringList.Create;
|
|
TypeFuncs := TStringList.Create;
|
|
|
|
case AObjectType of
|
|
gtObject :; // do nothing
|
|
gtClass : ParentType:=ParenParams(GetParentType(TgirClass(AItem)));
|
|
gtClassStruct : ;// do nothing;
|
|
gtInterface: ;
|
|
gtGType: ;
|
|
else
|
|
girError(geWarn, 'Got Object Type I don''t understand: ' + GirTokenName[AObjectType]);
|
|
end;
|
|
|
|
if AItem.InheritsFrom(TgirGType) then
|
|
begin
|
|
AddGetTypeProc(TgirGType(AItem));
|
|
end;
|
|
TypeDecl.Add(IndentText(AItem.TranslatedName +' = object'+ParentType,2,0));
|
|
|
|
// 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, AddedBitSizedType);
|
|
if AItem.CType <> 'GInitiallyUnowned' then // empty type GInitiallyUnowned is empty and aliased to GObject which causes
|
|
// object introspection to add the types again which causes size mismatches
|
|
// since it's supposed to be empty...how many places does that happen...
|
|
begin
|
|
WrittenFields:=0;
|
|
for i := 0 to Aitem.Fields.Count-1 do begin
|
|
HandleFieldType(AItem.Fields.Field[i], False, AddedBitSizedType);
|
|
if HasPackedBitfield(PackedBits) and (not AddedBitSizedType or (i = AItem.Fields.Count-1) )then
|
|
WantTypeSection.Lines.Add(EndPackedBits(PackedBits));
|
|
end;
|
|
end;
|
|
|
|
if TypeFuncs.Count > 0 then
|
|
TypeDecl.AddStrings(TypeFuncs);
|
|
|
|
TypeDecl.Add(' end;');
|
|
|
|
TypeSect := WantTypeSection;
|
|
|
|
TypeSect.Lines.AddStrings(TypeDecl);
|
|
TypeDecl.Free;
|
|
UsedNames.Free;
|
|
|
|
if UnitFuncs.Count > 0 then
|
|
FGroup.GetUnitForType(utFunctions).WantFunctionSection.Lines.AddStrings(UnitFuncs);
|
|
UnitFuncs.Free;
|
|
TypeFuncs.Free;
|
|
|
|
end;
|
|
|
|
procedure TPascalUnit.HandleUnion(AItem: TgirUnion);
|
|
var
|
|
ProperUnit: TPascalUnit;
|
|
begin
|
|
ProperUnit := FGroup.GetUnitForType(utTypes);
|
|
if ProperUnit <> Self then
|
|
begin
|
|
ProperUnit.HandleUnion(AItem);
|
|
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
|
|
TypeSect: TPDeclarationType;
|
|
begin
|
|
TypeSect := WantTypeSection;
|
|
ResolveTypeTranslation(AType);
|
|
AType.ImpliedPointerLevel := 1; // will only grow
|
|
TypeSect.Lines.Add('');
|
|
//TypeSect.Lines.Add(' { forward declaration for '+AType.TranslatedName+'}');
|
|
WritePointerTypesForType(AType, AType.TranslatedName, AType.ImpliedPointerLevel, TypeSect.Lines);
|
|
end;
|
|
|
|
begin
|
|
if AType.InheritsFrom(TgirFuzzyType) and (TgirFuzzyType(AType).ResolvedType <> nil) then
|
|
begin
|
|
TgirFuzzyType(AType).ResolvedType.ImpliedPointerLevel := AType.ImpliedPointerLevel;
|
|
AType := TgirFuzzyType(AType).ResolvedType;
|
|
end;
|
|
|
|
if AType.ForwardDefinitionWritten then
|
|
Exit;
|
|
|
|
WriteForward;
|
|
case AType.ObjectType of
|
|
otObject,
|
|
otGType,
|
|
otClass,
|
|
otClassStruct: ;
|
|
|
|
otAlias: ProcessType(AType, True);
|
|
otCallback: ProcessType(AType, True);
|
|
otEnumeration: ;
|
|
otBitfield: ;
|
|
otRecord: ;
|
|
otFunction: ;
|
|
otNativeType : ;
|
|
otInterface: ;
|
|
end;
|
|
Atype.ForwardDefinitionWritten:=True;
|
|
end;
|
|
|
|
procedure TPascalUnit.WriteWrapperForObject(ARoutineType, AObjectName,
|
|
AObjectFunctionName: String; AParams: TgirParamList; AFunctionReturns: String; AFlatFunctionName: String; AWantSelf: Boolean);
|
|
const
|
|
Decl = '%s %s.%s%s%s'+LineEnding;
|
|
Body = 'begin'+LineEnding+
|
|
' %s%s(%s);'+LineEnding+
|
|
'end;'+LineEnding;
|
|
var
|
|
Params: String;
|
|
CallParams: String;
|
|
Code: TPCodeText;
|
|
ResultStr: String = '';
|
|
Args: String;
|
|
Param: TGirFunctionParam;
|
|
begin
|
|
if AWantSelf then
|
|
begin
|
|
CallParams := '';
|
|
// old gir files don't have the instance-param
|
|
if AParams.Count < 1 then
|
|
CallParams:='@'
|
|
else
|
|
begin
|
|
Param := AParams.Param[0];
|
|
if Param.IsInstanceParam then
|
|
begin
|
|
if ((Param.PointerLevel > 0) or (Param.ImpliedPointerLevel > 0))
|
|
and ((Pos('*', Param.CType)>0) or ((Pos('pointer', Param.CType)>0)))
|
|
then
|
|
CallParams:='@'+Param.TranslatedName;
|
|
end
|
|
else // old gir files don't have the instance-param
|
|
CallParams:='@';
|
|
end;
|
|
|
|
if (AParams.Count = 0) or ((AParams.Count = 1) and AParams.Param[0].IsInstanceParam) then
|
|
CallParams+='self'
|
|
else
|
|
CallParams+='self, ';
|
|
end
|
|
else
|
|
CallParams:='';
|
|
if (ARoutineType = 'function') or (ARoutineType='constructor') then
|
|
ResultStr := 'Result := ';
|
|
Params:=WriteFunctionParams(AParams, @Args, not AWantSelf);
|
|
CallParams:=CallParams+Args;
|
|
Code := TPCodeText.Create;
|
|
Code.Content := Format(Decl, [ARoutineType, AObjectName, AObjectFunctionName, ParenParams(Params), AFunctionReturns])+
|
|
Format(Body, [ResultStr, FGroup.UnitForType[utFunctions].UnitFileName+'.'+AFlatFunctionName,
|
|
CallParams]);
|
|
ImplementationSection.Declarations.Add(Code);
|
|
|
|
|
|
end;
|
|
|
|
function TPascalUnit.WriteCallBack(AItem: TgirFunction; IsInObject: Boolean; AExistingUsedNames: TStringList = nil): String;
|
|
var
|
|
RoutineType: String;
|
|
Returns: String;
|
|
CBName: String;
|
|
Symbol: String;
|
|
Params: String;
|
|
begin
|
|
WriteFunctionTypeAndReturnType(AItem, RoutineType, Returns);
|
|
|
|
if IsInObject then
|
|
begin
|
|
CBName:=SanitizeName(AItem.Name, AExistingUsedNames);
|
|
Symbol := ': ';
|
|
end
|
|
else
|
|
begin
|
|
if AItem.CType <> '' then
|
|
CBName:=MakePascalTypeFromCType(AItem.CType)
|
|
else
|
|
CBName:=MakePascalTypeFromCType(NameSpace.CPrefix+AItem.Name);
|
|
Symbol := ' = ';
|
|
end;
|
|
|
|
Params := WriteFunctionParams(AItem.Params);
|
|
|
|
Result := CBName+Symbol+RoutineType+ParenParams(Params)+Returns;
|
|
|
|
end;
|
|
|
|
procedure TPascalUnit.WriteFunctionTypeAndReturnType(AItem: TgirFunction;
|
|
out AFunctionType, AFunctionReturnType: String);
|
|
begin
|
|
ResolveTypeTranslation(AItem.Returns.VarType);
|
|
if ((AItem.Returns.VarType.CType = 'void') or (AItem.Returns.VarType.Name = 'none'))
|
|
and (AItem.Returns.PointerLevel = 0) then
|
|
begin
|
|
AFunctionType:='procedure';
|
|
AFunctionReturnType := '; cdecl;';
|
|
end
|
|
else
|
|
begin
|
|
AFunctionType:='function';
|
|
AFunctionReturnType:= ': '+TypeAsString(AItem.Returns.VarType, AItem.Returns.PointerLevel, AItem.Returns.CType)+'; cdecl;' ;
|
|
|
|
// will skip if written
|
|
ProcessType(AItem.Returns.VarType);
|
|
end;
|
|
end;
|
|
|
|
function TPascalUnit.WriteFunctionParams(AParams: TgirParamList; AArgs: PString = nil; AIncludeInstanceParam: Boolean = false): String;
|
|
var
|
|
i: Integer;
|
|
ArgName: String;
|
|
Dummy: Boolean;
|
|
begin
|
|
Result := '';
|
|
if AArgs <> nil then
|
|
AArgs^ := '';
|
|
for i := 0 to AParams.Count-1 do
|
|
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)
|
|
else
|
|
Continue;
|
|
|
|
if i < AParams.Count-1 then
|
|
begin
|
|
Result := Result +'; ';
|
|
if AArgs <> nil then
|
|
AArgs^:=AArgs^+ArgName+', ';
|
|
end
|
|
else
|
|
if AArgs <> nil then
|
|
AArgs^:=AArgs^+ArgName;
|
|
end;
|
|
end;
|
|
|
|
function TPascalUnit.TypeAsString(AType: TGirBaseType; APointerLevel: Integer; ACTypeAsBackup: String = ''): String;
|
|
var
|
|
BackupNoPointers: String;
|
|
TranslatedName: String;
|
|
|
|
function NameIsPointerType(AName: String): Boolean;
|
|
begin
|
|
Result := ((AName = 'gpointer') or(AName = 'gconstpointer'))
|
|
and (TranslatedName <> AName)
|
|
and (TranslatedName <> '');
|
|
end;
|
|
begin
|
|
ResolveTypeTranslation(AType);
|
|
TranslatedName := AType.TranslatedName;
|
|
|
|
BackupNoPointers := StringReplace(ACTypeAsBackup, '*', '', [rfReplaceAll]);
|
|
|
|
// some types are pointers but contain no "*" so it thinks it has a pointer level 0 when really it's 1
|
|
if (APointerLevel = 0) and (NameIsPointerType(ACTypeAsBackup)) then
|
|
begin
|
|
APointerLevel := 1;
|
|
end;
|
|
|
|
if APointerLevel = 0 then
|
|
begin
|
|
Result := AType.TranslatedName;
|
|
if Result = '' then
|
|
Result := NameSpace.LookupTypeByName(BackupNoPointers, '').TranslatedName;
|
|
end
|
|
else
|
|
begin
|
|
if AType.CType = '' then
|
|
AType.CType:=ACTypeAsBackup;
|
|
Result := MakePascalTypeFromCType(AType.CType, APointerLevel);
|
|
end;
|
|
if APointerLevel > AType.ImpliedPointerLevel then
|
|
begin
|
|
girError(geFatal, 'Trying to use a pointerlevel > written level!');
|
|
Halt;
|
|
end;
|
|
end;
|
|
|
|
procedure TPascalUnit.AssembleUsedFieldNamesFromParent(const AParent: TgirClass; var AUsedNamesList: TStringList);
|
|
var
|
|
Field: TGirBaseType;
|
|
i: Integer;
|
|
begin
|
|
if AParent = nil then
|
|
Exit;
|
|
|
|
AssembleUsedFieldNamesFromParent(AParent.ParentClass, AUsedNamesList);
|
|
for i := 0 to AParent.Fields.Count-1 do
|
|
begin
|
|
Field := AParent.Fields.Field[i];
|
|
case Field.ObjectType of
|
|
otArray,
|
|
otTypeParam,
|
|
otCallback,
|
|
otProperty:
|
|
begin
|
|
// adds name to list
|
|
SanitizeName(Field.Name, AUsedNamesList);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TPascalUnit.WriteParamAsString(AParentName: String; AParam: TgirTypeParam; AIndex: Integer; out ABitSizeSpecified: Boolean; AFirstParam: PString; AExistingUsedNames: TStringList): String;
|
|
var
|
|
PT: String;
|
|
PN: String;
|
|
IsArray: Boolean;
|
|
AnArray: TgirArray absolute AParam;
|
|
begin
|
|
ABitSizeSpecified:=False;
|
|
if AParam.VarType = nil then
|
|
begin
|
|
// is a varargs param
|
|
Result := 'args: array of const';// 'args: varargs'; // varargs must be append to the function definition also this is more clear to the user
|
|
exit;
|
|
end;
|
|
|
|
IsArray := AParam.InheritsFrom(TgirArray) ;
|
|
|
|
//if Length(AParam.VarType.Name) < 1 then
|
|
//begin
|
|
//WriteLn('AParam.VarType.Name is empty. AParam.Name = ', AParam.Name,' AParam.CType = ', AParam.CType, ' AParam.VarType.CType = ',AParam.VarType.CType);
|
|
//end;
|
|
PT := '';
|
|
if IsArray and (AnArray.FixedSize > 0) then
|
|
PT := 'array [0..'+IntToStr(TgirArray(AParam).FixedSize-1)+'] of ' ;
|
|
PT := PT+ TypeAsString(AParam.VarType, AParam.PointerLevel, AParam.CType);
|
|
|
|
if IsArray and (AnArray.FixedSize = 0) then
|
|
PN := AnArray.ParentFieldName
|
|
else
|
|
PN := AParam.Name;
|
|
|
|
if PN = '' then
|
|
PN := 'param'+IntToStr(AIndex);
|
|
PN := SanitizeName(PN, AExistingUsedNames);
|
|
|
|
if AFirstParam <> nil then
|
|
AFirstParam^:=PN;
|
|
|
|
if AParam.Bits > 0 then
|
|
begin
|
|
ABitSizeSpecified:=True;
|
|
case AParam.Bits of
|
|
//16: PT := 'guint16 { changed from '+PT+' to accomodate 16 bitsize requirement }';
|
|
//32: PT := 'guint32 { changed from '+PT+' to accomodate 32 bitsize requirement }';
|
|
1..32:
|
|
PT := Format('guint%d { changed from %s to accomodate %d bitsize requirement }',[AParam.Bits, PT, AParam.Bits]);
|
|
else
|
|
girError(geWarn, 'Bits are Set to [ '+IntToStr(AParam.Bits)+' ]for: ' +PN+': '+PT);
|
|
PT +=' { ERROR : Bits are Set to [ '+IntToStr(AParam.Bits)+' ] }';
|
|
end;
|
|
|
|
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;
|
|
|
|
function TPascalUnit.WriteRecord(ARecord: TgirRecord; ABaseIndent: Integer = 0; AIsUnion: Boolean = False): String;
|
|
var
|
|
PackedBits: TStringList = nil;
|
|
PackedBitsCount: Integer = 0;
|
|
AddedBitSizedType: Boolean;
|
|
TypeDecl: TStringList;
|
|
i: Integer;
|
|
function AddField(AField: TGirBaseType): Boolean;
|
|
var
|
|
Param: String;
|
|
// Iten
|
|
begin
|
|
Result := False;
|
|
Param := WriteParamAsString(ARecord.Name, TgirTypeParam(AField),i, Result);
|
|
if Result and not AIsUnion then
|
|
PackedBitsAddEntry(PackedBits, ARecord, PackedBitsCount, Param, TypeDecl)
|
|
else
|
|
TypeDecl.Add(IndentText(Param+';',ABaseIndent+4,0));
|
|
end;
|
|
var
|
|
Field: TGirBaseType;
|
|
UseName: String;
|
|
Symbol: String;
|
|
|
|
begin
|
|
TypeDecl := TStringList.Create;
|
|
TypeDecl.Add('');
|
|
if Not AIsUnion then
|
|
begin
|
|
UseName:=ARecord.TranslatedName;
|
|
Symbol := ' = ';
|
|
end
|
|
else
|
|
begin
|
|
UseName:=ARecord.Name;
|
|
Symbol:= ' : ';
|
|
end;
|
|
TypeDecl.Add(IndentText(UseName +Symbol+ 'record',ABaseIndent+2,0));
|
|
|
|
// If a type size = 0 then this can cause problems for the compiler! bug 20265
|
|
//if ARecord.Fields.Count = 0 then
|
|
// TypeDecl.Add(IndentText('Unknown: Pointer;', ABaseIndent+4,0));
|
|
|
|
for i := 0 to ARecord.Fields.Count-1 do
|
|
begin
|
|
AddedBitSizedType:=False;
|
|
Field := ARecord.Fields.Field[i];
|
|
case Field.ObjectType of
|
|
otArray,
|
|
otTypeParam: AddedBitSizedType := AddField(Field);
|
|
otCallback : TypeDecl.Add(IndentText(WriteCallBack(TgirCallback(Field),True),ABaseIndent+4,0));
|
|
otUnion: TypeDecl.Add(IndentText(WriteUnion(TgirUnion(Field), True, ABaseIndent),ABaseIndent+4));
|
|
else
|
|
TypeDecl.Add(IndentText(Field.Name+ ' ' + Field.ClassName,4,0)); // this of course will make the compiler barf
|
|
end;
|
|
if HasPackedBitfield(PackedBits) and ((i = ARecord.Fields.Count-1) or (not AddedBitSizedType)) then
|
|
WantTypeSection.Lines.Add(EndPackedBits(PackedBits));
|
|
|
|
end;
|
|
TypeDecl.Add(IndentText('end;',ABaseIndent+2,1));
|
|
Result := TypeDecl.Text;
|
|
end;
|
|
|
|
function TPascalUnit.WriteUnion(AUnion: TgirUnion; ASkipRecordName: Boolean; ABaseIndent: Integer
|
|
): String;
|
|
var
|
|
Union: TStringList;
|
|
i: Integer;
|
|
Field: TGirBaseType;
|
|
Dummy: Boolean;
|
|
begin
|
|
Union := TStringList.Create;
|
|
|
|
if not ASkipRecordName then
|
|
Union.Add(IndentText(AUnion.TranslatedName+' = record', ABaseIndent,0));
|
|
if AUnion.Fields.Count > 0 then
|
|
Union.Add(IndentText('case longint of',ABaseIndent+2,0));
|
|
for i := 0 to AUnion.Fields.Count-1 do
|
|
begin
|
|
Field := AUnion.Fields.Field[i];
|
|
case Field.ObjectType of
|
|
otArray,
|
|
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;
|
|
otConstructor,
|
|
otFunction : Union.Add(IndentText('//'+WriteFunction(TgirFunction(Field), AUnion, False, False, WantFunctionSection.Lines), ABaseIndent+2,0));
|
|
otMethod : Union.Add(IndentText('//'+WriteFunction(TgirFunction(Field), AUnion, True, False, WantFunctionSection.Lines), ABaseIndent+2,0));
|
|
else
|
|
Union.Add('// Unhandled type for Union: '+ Field.ClassName); // this won't compile obviously
|
|
girError(geWarn, 'Unhandled type for Union: '+ Field.ClassName);
|
|
end;
|
|
|
|
end;
|
|
if not ASkipRecordName then
|
|
Union.Add(IndentText('end;', ABaseIndent));
|
|
REsult := Union.Text;
|
|
Union.Free;
|
|
|
|
end;
|
|
|
|
function TPascalUnit.ParenParams(const AParams: String; const AForceParens: Boolean = False): String;
|
|
begin
|
|
Result := '';
|
|
if (AParams <> '') or AForceParens then
|
|
Result := '('+AParams+')';
|
|
end;
|
|
|
|
procedure TPascalUnit.WriteDynamicLoadUnloadProcs;
|
|
var
|
|
Dyn: TStrings;
|
|
Libs: TStringList;
|
|
LibNames: array of string;
|
|
InitCode: TPCodeText;
|
|
FinalCode: TPCodeText;
|
|
procedure AddLibVars;
|
|
var
|
|
Lib: String;
|
|
i: Integer;
|
|
begin
|
|
Dyn.Add('var');
|
|
SetLength(LibNames, Libs.Count);
|
|
for i := 0 to Libs.Count-1 do
|
|
begin
|
|
Lib := Libs[i];
|
|
LibNames[i] := SanitizeName(Lib);
|
|
Dyn.Add(' '+LibNames[i] + ': TLibHandle;');
|
|
end;
|
|
end;
|
|
|
|
procedure WriteLoadLibrary;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Dyn.Add('procedure LoadLibraries;');
|
|
Dyn.Add('begin');
|
|
for i := 0 to Libs.Count-1 do
|
|
Dyn.Add(' '+LibNames[i]+' := SafeLoadLibrary('''+Libs[i]+''');');
|
|
Dyn.Add('end;');
|
|
Dyn.Add('');
|
|
|
|
InitCode.Lines.Add('LoadLibraries;');
|
|
|
|
end;
|
|
procedure WriteLoadProcs;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Dyn.Add('procedure LoadProcs;');
|
|
Dyn.Add(' procedure LoadProc(var AProc: Pointer; AName: String);');
|
|
Dyn.Add(' var');
|
|
Dyn.Add(' ProcPtr: Pointer;');
|
|
Dyn.Add(' begin');
|
|
Dyn.Add(' ProcPtr := GetProcedureAddress('+LibNames[0]+', AName);');
|
|
if Libs.Count > 0 then
|
|
begin
|
|
for i := 1 to Libs.Count-1 do begin
|
|
Dyn.Add(' if ProcPtr = nil then');
|
|
Dyn.Add(' ProcPtr := GetProcedureAddress('+LibNames[i]+', AName);');
|
|
end;
|
|
end;
|
|
Dyn.Add(' AProc := ProcPtr;');
|
|
Dyn.Add(' end;');
|
|
// Now the Main procedure starts
|
|
Dyn.Add('begin');
|
|
for i := 0 to FDynamicEntryNames.Count-1 do
|
|
Dyn.Add(' LoadProc(Pointer('+FDynamicEntryNames[i]+'), '''+FDynamicEntryNames[i]+''');');
|
|
Dyn.Add('end;');
|
|
Dyn.Add('');
|
|
|
|
InitCode.Lines.Add('LoadProcs;');
|
|
|
|
end;
|
|
|
|
procedure WriteUnloadLibrary;
|
|
var
|
|
Tmp: String;
|
|
begin
|
|
Dyn.Add('procedure UnloadLibraries;');
|
|
Dyn.Add('begin');
|
|
for Tmp in LibNames do
|
|
begin
|
|
Dyn.Add(' if '+ Tmp+ ' <> 0 then');
|
|
Dyn.Add(' UnloadLibrary('+Tmp+');');
|
|
Dyn.Add(' '+Tmp+' := 0;');
|
|
end;
|
|
for Tmp in FDynamicEntryNames do
|
|
Dyn.Add(' '+Tmp+' := nil;');
|
|
Dyn.Add('end;');
|
|
Dyn.Add('');
|
|
|
|
FinalCode.Lines.Add('UnloadLibraries;');
|
|
end;
|
|
|
|
begin
|
|
if FDynamicEntryNames.Count = 0 then
|
|
Exit;
|
|
Libs := GetLibs;
|
|
if Libs.Count = 0 then
|
|
begin
|
|
Libs.Free;
|
|
Exit;
|
|
end;
|
|
Dyn := FDynamicLoadUnloadSection.Lines;
|
|
InitCode := TPCodeText.Create;
|
|
FinalCode := TPCodeText.Create;
|
|
InitializeSection.Declarations.Add(InitCode);
|
|
FinalizeSection.Declarations.Add(FinalCode);
|
|
|
|
|
|
AddLibVars;
|
|
WriteLoadLibrary;
|
|
WriteLoadProcs;
|
|
WriteUnloadLibrary;
|
|
Libs.Free;
|
|
end;
|
|
|
|
function TPascalUnit.GetLibs: TStringList;
|
|
begin
|
|
Result := TStringList.Create;
|
|
Result.Delimiter:=',';
|
|
Result.StrictDelimiter:= True;
|
|
Result.CommaText:=NameSpace.SharedLibrary;
|
|
end;
|
|
|
|
function TPascalUnit.SanitizeName(AName: String; AExistingUsedNames: TStringList = nil): String;
|
|
var
|
|
PascalReservedWords : array[0..32] of String =
|
|
('begin', 'end', 'type', 'of', 'in', 'out', 'function', 'string','file', 'default',
|
|
'procedure', 'string', 'boolean', 'array', 'set', 'destructor', 'destroy', 'program',
|
|
'property', 'object', 'private', 'constructor', 'inline', 'result', 'interface',
|
|
'const', 'raise', 'unit', 'label', 'xor', 'implementation','var','to');
|
|
Name: String;
|
|
Sanity: Integer = 0;
|
|
Sucess: Boolean;
|
|
TestName: String;
|
|
begin
|
|
Result := AName;
|
|
|
|
for Name in PascalReservedWords do
|
|
if Name = LowerCase(AName) then
|
|
Result := Aname+'_';
|
|
|
|
Result := StringReplace(Result, '-','_',[rfReplaceAll]);
|
|
Result := StringReplace(Result, ' ','_',[rfReplaceAll]);
|
|
Result := StringReplace(Result, '.','_',[rfReplaceAll]);
|
|
|
|
if AExistingUsedNames <> nil then
|
|
begin
|
|
// AExistingUsedNames must be set to sorted and duplucate strings caues an error;
|
|
TestName:=Result;
|
|
repeat
|
|
Inc(Sanity);
|
|
try
|
|
AExistingUsedNames.Add(LowerCase(TestName));
|
|
Result := TestName;
|
|
Sucess := True;
|
|
except
|
|
TestName := Result + IntToStr(Sanity);
|
|
Sucess := False;
|
|
end;
|
|
|
|
until Sucess or (Sanity > 300);
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TPascalUnit.ResolveTypeTranslation(ABaseType: TGirBaseType);
|
|
var
|
|
RawName: String;
|
|
begin
|
|
if ABaseType.TranslatedName = '' then
|
|
begin
|
|
RawName := ABaseType.CType;
|
|
if RawName = '' then
|
|
RawName:= NameSpace.CPrefix+ABaseType.Name;
|
|
ABaseType.TranslatedName:=MakePascalTypeFromCType(RawName, 0);
|
|
end;
|
|
end;
|
|
|
|
constructor TPascalUnit.Create(AGroup: TPascalUnitGroup; ANameSpace: TgirNamespace; AOptions: TgirOptions; AUnitType: TPascalUnitTypes; AUnitPrefix: String);
|
|
const
|
|
//CBasic = '#include <%s>'+LineEnding;
|
|
PBasic = 'program %s_test;'+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;
|
|
FGroup := AGroup;
|
|
FOptions := AOptions;
|
|
FUnitType:=AUnitType;
|
|
FUnitPrefix := AUnitPrefix;
|
|
FFinalizeSection := TPFinialization.Create(Self);
|
|
FImplementationSection := TPImplementation.Create(Self);
|
|
FInitializeSection := TPInitialize.Create(Self);
|
|
FInterfaceSection := TPInterface.Create(Self, TPUses.Create, goLinkDynamic in FOptions);
|
|
FDynamicLoadUnloadSection := TPCodeText.Create;
|
|
FDynamicEntryNames := TStringList.Create;
|
|
FDynamicEntryNames.Sorted:=True;
|
|
FDynamicEntryNames.Duplicates := dupIgnore;
|
|
FNameSpace := ANameSpace;
|
|
|
|
if goWantTest in FOptions then
|
|
begin
|
|
//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();'); // deprecated since GLib 2.36
|
|
|
|
end;
|
|
ResolveFuzzyTypes;
|
|
end;
|
|
|
|
destructor TPascalUnit.Destroy;
|
|
begin
|
|
if goWantTest in FOptions then
|
|
begin
|
|
FTestPascalFile.Free;
|
|
//FTestCFile.Free;
|
|
FTestPascalBody.Free;
|
|
end;
|
|
FFinalizeSection.Free;
|
|
FImplementationSection.Free;
|
|
FInitializeSection.Free;
|
|
FInterfaceSection.Free;
|
|
FDynamicLoadUnloadSection.Free;
|
|
FDynamicEntryNames.Free;
|
|
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TPascalUnit.ProcessConsts(AList: TList; AUsedNames: TStringList);
|
|
function WriteConst(AConst: TgirConstant; Suffix: String = ''): String;
|
|
begin
|
|
if AConst.IsString then
|
|
Result := AConst.CName + Suffix+' = '+QuotedStr(AConst.Value)+';'
|
|
else
|
|
Result := AConst.CName + Suffix+' = '+AConst.Value+';';
|
|
end;
|
|
|
|
var
|
|
NewConst: TPDeclarationConst;
|
|
Item: TgirConstant;
|
|
i: Integer;
|
|
Consts: TStringList; // this is to check for duplicates
|
|
Entry: String;
|
|
Suffix: String;
|
|
Sanity: Integer;
|
|
begin
|
|
NewConst := WantConstSection;
|
|
Consts := TStringList.Create;
|
|
Consts.Sorted:=True;
|
|
Consts.Duplicates:=dupError;
|
|
|
|
|
|
for i := 0 to AList.Count-1 do
|
|
begin
|
|
Sanity := 0;
|
|
Suffix := '';
|
|
Item := TgirConstant(AList.Items[i]);
|
|
|
|
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
|
|
if Sanity > 0 then
|
|
Suffix := '__'+IntToStr(Sanity)
|
|
else Suffix := '_';
|
|
end;
|
|
Inc(Sanity);
|
|
until Sanity > 10;
|
|
|
|
NewConst.Lines.AddObject(IndentText(WriteConst(Item, Suffix), 2,0), Item);
|
|
end;
|
|
end;
|
|
|
|
procedure TPascalUnit.ProcessTypes(AList: TFPHashObjectList);
|
|
|
|
var
|
|
BaseType: TGirBaseType;
|
|
i: Integer;
|
|
begin
|
|
if AList.Count = 0 then
|
|
Exit;
|
|
|
|
for i := 0 to AList.Count-1 do
|
|
begin
|
|
BaseType := TGirBaseType(AList.Items[i]);
|
|
if not MeetsVersionConstraints(BaseType) then
|
|
Continue;
|
|
ProcessType(BaseType);
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TPascalUnit.ProcessFunctions(AList: TList);
|
|
var
|
|
i: Integer;
|
|
Func: TgirFunction;
|
|
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;
|
|
|
|
procedure TPascalUnit.GenerateUnit;
|
|
var
|
|
i: Integer;
|
|
NS: TgirNamespace;
|
|
ImplementationUses: TPUses;
|
|
NeedUnit: String;
|
|
iswindows : boolean;
|
|
UnixName,
|
|
WindowsName : String;
|
|
|
|
begin
|
|
for i := 0 to FNameSpace.RequiredNameSpaces.Count-1 do
|
|
begin
|
|
NS := TgirNamespace(FNameSpace.RequiredNameSpaces.Items[i]);
|
|
NeedUnit:=FGroup.FUnitPrefix + CalculateUnitName(NS.NameSpace,NS.Version.AsString);
|
|
|
|
if FUnitType = PascalUnitTypeAll then
|
|
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit)
|
|
else
|
|
begin
|
|
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit+'Common');
|
|
if (utClasses in FUnitType) then
|
|
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit+'Classes');
|
|
if (utObjects in FUnitType) then
|
|
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit+'Objects');
|
|
end;
|
|
|
|
|
|
{case FUnitType of
|
|
utSimple: InterfaceSection.UsesSection.Units.Add(' '+NeedUnit);
|
|
utConsts: ; // do nothing
|
|
|
|
utFunctions,
|
|
utTypes:
|
|
begin
|
|
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit+'Consts');
|
|
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit+'Types');
|
|
end;
|
|
|
|
utObjects,
|
|
utClasses:
|
|
begin
|
|
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit+'Consts');
|
|
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit+'Types');
|
|
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit+'Functions');
|
|
end;
|
|
end;}
|
|
end;
|
|
if utFunctions in FUnitType then
|
|
begin
|
|
if goLinkDynamic in FOptions then
|
|
begin
|
|
ImplementationUses := TPUses.Create;
|
|
ImplementationUses.Units.Add('DynLibs');
|
|
ImplementationSection.Declarations.Add(ImplementationUses);
|
|
end
|
|
else // Not linking dynamically
|
|
begin
|
|
isWindows:=Pos('.dll',NameSpace.SharedLibrary)>0;
|
|
i := Pos(',',NameSpace.SharedLibrary);
|
|
if i > 0 then
|
|
LibName:=Copy(NameSpace.SharedLibrary,1,i-1)
|
|
else
|
|
LibName:=NameSpace.SharedLibrary;
|
|
if isWindows then
|
|
begin
|
|
WindowsName:=LibName;
|
|
UnixName:=changefileext(LibName,'')+'.so';
|
|
end
|
|
else
|
|
begin
|
|
WindowsName:=changefileext(LibName,'')+'.dll';
|
|
UnixName:=LibName;;
|
|
end;
|
|
|
|
WantConstSection.Lines.Add(IndentText('{$ifdef MsWindows}',2,0));
|
|
WantConstSection.Lines.Add(IndentText(UnitName+'_library = '''+WindowsName+''';', 2,0));
|
|
WantConstSection.Lines.Add(IndentText('{$else}',2,0));
|
|
WantConstSection.Lines.Add(IndentText(UnitName+'_library = '''+Unixname+''';', 2,0));
|
|
WantConstSection.Lines.Add(IndentText('{$endif}',2));
|
|
end;
|
|
end;
|
|
|
|
if NameSpace.NameSpace = 'GLib' then
|
|
AddGLibSupportCode;
|
|
|
|
end;
|
|
|
|
function TPascalUnit.AsStream: TStringStream;
|
|
var
|
|
Str: TStringStream absolute Result;
|
|
Libs: TStringList;
|
|
i: Integer;
|
|
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('{$MODE OBJFPC}{$H+}',0,2));
|
|
if utTypes in FUnitType then
|
|
Str.WriteString(IndentText('{$PACKRECORDS C}',0,1));
|
|
//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));
|
|
//if FUnitType in [utSimple, utObjects] then
|
|
Str.WriteString(IndentText('{$MODESWITCH DUPLICATELOCALS+}',0,2));
|
|
|
|
if (utFunctions in FUnitType) and not (goLinkDynamic in FOptions) then
|
|
begin
|
|
Str.WriteString(IndentText('{$ifdef Unix}',0,1)); // Probably needs handling for OS X frameworks too.
|
|
for i := 0 to Libs.Count-1 do
|
|
Str.WriteString(IndentText('{$LINKLIB '+Libs.Strings[i]+'}',0,1));
|
|
Str.WriteString(IndentText('{$endif}',0,1));
|
|
Str.WriteString(IndentText('{$WARN 3031 off : Values in enumeration types have to be ascending}', 0, 1));
|
|
end;
|
|
|
|
Libs.Free;
|
|
|
|
Str.WriteString(InterfaceSection.AsString);
|
|
Str.WriteString(ImplementationSection.AsString);
|
|
|
|
if (goLinkDynamic in FOptions) then
|
|
begin
|
|
WriteDynamicLoadUnloadProcs;
|
|
Str.WriteString(DynamicLoadUnloadSection.AsString);
|
|
end;
|
|
|
|
if InitializeSection.Declarations.Count > 0 then
|
|
Str.WriteString(InitializeSection.AsString);
|
|
|
|
if FinalizeSection.Declarations.Count > 0 then
|
|
Str.WriteString(FinalizeSection.AsString);
|
|
|
|
Str.WriteString('end.' + LineEnding);
|
|
|
|
Result.Position:=0;
|
|
end;
|
|
|
|
procedure TPascalUnit.Finish;
|
|
begin
|
|
if (goWantTest in FOptions) then
|
|
begin
|
|
FTestPascalFile.WriteString(FTestPascalBody.Text);
|
|
FTestPascalFile.WriteString('end.' + LineEnding);
|
|
//FTestCFile.Position:=0;
|
|
FTestPascalFile.Position:=0;
|
|
end;
|
|
end;
|
|
|
|
{ TPDeclarationList }
|
|
|
|
function TPDeclarationList.GetDeclarations(AIndex: Integer): TPDeclaration;
|
|
begin
|
|
Result := TPDeclaration(Items[AIndex]);
|
|
end;
|
|
|
|
function TPDeclarationList.AsString: String;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := '';
|
|
for i := 0 to Count-1 do
|
|
begin
|
|
Result := Result+Declarations[i].AsString+LineEnding;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
|
|
end.
|
|
|