From 8d7b0d7e6e002bebd9174baccfb59f02239bbe85 Mon Sep 17 00:00:00 2001 From: drewski207 Date: Sun, 26 Aug 2012 20:05:29 +0000 Subject: [PATCH] Removed CustApp dependency of gir2pas Implemented some small amount of framework to create pascal classes from gobjects. Fixed some bugs where properties would not find setters and getters properly when actually available git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2493 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../commandlineoptions.pas | 399 +++ .../gobject-introspection/gir2pascal.lpi | 27 +- .../gobject-introspection/gir2pascal.lpr | 171 +- .../gobject-introspection/girerrors.pas | 2 +- .../gobject-introspection/girnamespaces.pas | 5 +- .../gobject-introspection/girobjects.pas | 39 +- .../girpascalclasswriter.pas | 42 + .../gobject-introspection/girpascalwriter.pas | 2112 +-------------- .../girpascalwritertypes.pas | 2400 +++++++++++++++++ .../gobject-introspection/girtokens.pas | 4 +- 10 files changed, 3051 insertions(+), 2150 deletions(-) create mode 100644 applications/gobject-introspection/commandlineoptions.pas create mode 100644 applications/gobject-introspection/girpascalclasswriter.pas create mode 100644 applications/gobject-introspection/girpascalwritertypes.pas diff --git a/applications/gobject-introspection/commandlineoptions.pas b/applications/gobject-introspection/commandlineoptions.pas new file mode 100644 index 000000000..13b6f81ef --- /dev/null +++ b/applications/gobject-introspection/commandlineoptions.pas @@ -0,0 +1,399 @@ +unit CommandLineOptions; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Contnrs; + +type + + { TOption } + + TOption = class + Names: array of String; + Values: array of String; + Identifier: Integer; + HasArg: Boolean; + Present: Boolean; + Help: String; + MultipleValues: Boolean; + function LongestName: String; + function Value: String; + procedure AddValue(AValue: String); + end; + TCommandLineOptions = class; + + + TOptionReadError = procedure(Sender: TObject; ErrorMessage: String) of object; + + { TCommandLineOptions } + + TCommandLineOptions = class + private + FOnError: TOptionReadError; + FOptions: TObjectList; + FUnassignedArgs: TStringList; + FStopReading: Boolean; + function FindOptionByName(AName: String): TOption; + function FindOptionByIdentifier(AIdentifier: Integer): TOption; + procedure DoError(ErrorMessage: String); virtual; + public + // first setup options + procedure SetOptions(ShortOptions: String; LongOptions: array of String); + procedure AddOption(OptionNames: array of String; HasArg: Boolean = False; Help: String = ''; CanUseMultipleTimes: Boolean = False; Identifier: Integer = -1); + // read from commandline + procedure ReadOptions; + + function HasOption(AName: String): Boolean; + function OptionValue(AName:String): String; + function OptionValues(AName: String): TStrings; + constructor Create; + destructor Destroy; override; + function PrintHelp(MaxLineWidth: Integer): TStrings; virtual; + property OnError: TOptionReadError read FOnError write FOnError; + property OptionsMalformed: Boolean read FStopReading; + end; +resourcestring + ErrUnknownOption = 'Option unknown: "%s"'; + ErrArgNeededNotPossible = 'Option "%s" requires an argument but an argument is not possible. (Hint: Use "%s" as last option in group "-%s" or use long option --%s)'; + ErrArgumentNeeded = 'Option "%s" requires an argument'; + ErrOptionHasNoArgument = 'Option "%s" does not accept arguments'; + ErrOnlyOneInstance = 'Option "%s" cannot be used more than once'; + ErrNoEqualsAllowed = 'Symbol "=" not allowed in argument group "-%s"'; +implementation + +{ TOption } + +function TOption.LongestName: String; +var + N: String; +begin + Result := ''; + for N in Names do + begin + if Length(N) > Length(Result) then + Result := N; + end; +end; + +function TOption.Value: String; +begin + if Length(Values) > 0 then + Exit(Values[0]) + else + Result := ''; +end; + +procedure TOption.AddValue(AValue: String); +begin + SetLength(Values, Length(Values)+1); + Values[High(Values)] := AValue; +end; + +{ TCommandLineOptions } + +function TCommandLineOptions.FindOptionByName(AName: String): TOption; +var + Opt: TOption; + N: String; +begin + Result := Nil; + for Pointer(Opt) in FOptions do + begin + for N in Opt.Names do + if AName = N then + Exit(Opt) + end; +end; + +function TCommandLineOptions.FindOptionByIdentifier(AIdentifier: Integer + ): TOption; +begin + +end; + +procedure TCommandLineOptions.DoError(ErrorMessage: String); +begin + FStopReading:=True; + if Assigned(FOnError) then + FOnError(Self, ErrorMessage) + else + WriteLn(ErrorMessage); +end; + +procedure TCommandLineOptions.SetOptions(ShortOptions: String; + LongOptions: array of String); +var + L: String; + S: String; + HasArg: Boolean; + P, + E: PChar; +begin + P:= PChar(ShortOptions); + E := P + Length(ShortOptions); + + for L in LongOptions do + begin + S := P[0]; + if P+1 < E then + HasArg:=P[1] = ':'; + Inc(P, 1+Ord(HasArg)); + AddOption([S, L], HasArg); + end; +end; + +procedure TCommandLineOptions.AddOption(OptionNames: array of String; + HasArg: Boolean; Help: String; CanUseMultipleTimes: Boolean; Identifier: Integer); +var + Opt: TOption; + C: Integer; +begin + Opt := TOption.Create; + C := Length(OptionNames); + SetLength(Opt.Names, C); + for C := Low(OptionNames) to High(OptionNames) do + Opt.Names[C] := OptionNames[C]; + Opt.HasArg:=HasArg; + Opt.Identifier:=Identifier; + Opt.MultipleValues:=CanUseMultipleTimes; + Opt.Help:=Help; + FOptions.Add(Opt); +end; + +procedure TCommandLineOptions.ReadOptions; +var + OptIndex: Integer; + procedure ReadOption(S, G: String; OptionPossible: Boolean); + var + Opt: TOption; + Arg: String; + HasEq: Integer = 0; + begin + HasEq := Pos('=', S); + if HasEq > 0 then + begin + Arg := Copy(S, HasEq+1, Length(S)); + S := Copy(S,1, HasEq-1); + end; + + Opt := FindOptionByName(S); + if Opt = Nil then + begin + DoError(Format(ErrUnknownOption, [S])); + Exit; + end; + if Opt.HasArg and not OptionPossible then + begin + DoError(Format(ErrArgNeededNotPossible, [S, S, G, Opt.LongestName])); + Exit; + end; + + if Opt.HasArg then + begin + if (OptIndex = Paramcount) and (HasEq = 0) then + begin + DoError(Format(ErrArgumentNeeded, [S])); + Exit; + end; + if Opt.Present and not Opt.MultipleValues then + begin + DoError(Format(ErrOnlyOneInstance, [S])); + Exit; + end; + + // Verify??? + + if HasEq = 0 then + begin + Arg := ParamStr(OptIndex+1); + Inc(OptIndex); + end; + Opt.AddValue(Arg); + end + else if HasEq > 0 then + begin + DoError(Format(ErrOptionHasNoArgument, [S])); + end; + + Opt.Present:=True; + end; + + procedure ReadSingleOptions(S: String); + var + I: Integer; + begin + if S[1] = '-' then // its a long option with 2 dashes : --option + ReadOption(Copy(S,2,Length(S)), '', True) + else // short options put together : -abcdefg + begin + if Pos('=', S) > 0 then + begin + DoError(Format(ErrNoEqualsAllowed,[S])); + Exit; + end; + for I := 1 to Length(S) do + ReadOption(S[I], S, I = Length(S)); + end; + end; +var + RawOpt: String; +begin + OptIndex:=0; + while OptIndex < Paramcount do + begin + if FStopReading then + Exit; + Inc(OptIndex); + RawOpt := ParamStr(OptIndex); + if (RawOpt[1] = '-') and (RawOpt <> '-') then // '-' is treated as an unassigned arg. + ReadSingleOptions(Copy(RawOpt,2,Length(RawOpt))) + else + FUnassignedArgs.Add(RawOpt); + end; +end; + +function TCommandLineOptions.HasOption(AName: String): Boolean; +var + Opt: TOption; +begin + Result := True; + Opt := FindOptionByName(AName); + if (Opt = nil) or not(Opt.Present) then + Result := False; +end; + +function TCommandLineOptions.OptionValue(AName: String): String; +var + Opt: TOption; + S: String; +begin + Opt := FindOptionByName(AName); + Result := Opt.Value; +end; + +function TCommandLineOptions.OptionValues(AName: String): TStrings; +var + Opt: TOption; + S: String; +begin + Opt := FindOptionByName(AName); + Result := TStringList.Create; + if Opt = nil then + Exit; + for S in Opt.Values do + Result.Add(S); +end; + +constructor TCommandLineOptions.Create; +begin + FOptions := TObjectList.create(True); + FUnassignedArgs := TStringList.Create; +end; + +destructor TCommandLineOptions.Destroy; +begin + FOptions.Clear; + FOptions.Free; + FUnassignedArgs.Free; + inherited Destroy; +end; + +function TCommandLineOptions.PrintHelp(MaxLineWidth: Integer): TStrings; +var + Padding: array [0..255] of char; + function Space(Orig: String; LengthNeeded: Integer; Before: Boolean = False): String; + begin + if not Before then + Result := Orig+Copy(Padding,0,LengthNeeded-Length(Orig)) + else + Result := Copy(Padding,0,LengthNeeded-Length(Orig))+Orig; + end; + +var + Opt: TOption; + Tmp: String; + Line: String; + LinePart: String; + I, J: Integer; + S,L,D: TStringList; // short opt, long opt, description + SL, LL: String; // short line, long line + SLL, LLL: Integer; //short line length, long line length + LineSize: Integer; + Gap: Integer; +begin + FillChar(Padding, 256, ' '); + S := TStringList.Create; + L := TStringList.Create; + D := TStringList.Create; + Result := TStringList.Create; + for I := 0 to FOptions.Count-1 do + begin + SL := ''; + LL := ''; + Line := ''; + Opt := TOption(FOptions.Items[I]); + for Tmp in Opt.Names do + if Length(Tmp) = 1 then + SL := SL + ' -' + Tmp + else + LL := LL + ' --' + Tmp; + + S.Add(SL); + L.Add(LL); + D.Add(Opt.Help); + end; + SLL := 0; + LLL := 0; + + for Tmp in S do + if Length(Tmp) > SLL then + SLL := Length(Tmp); + + for Tmp in L do + if Length(Tmp) > LLL then + LLL := Length(Tmp); + + + for I := 0 to S.Count-1 do + begin + LinePart := ''; + SL := Space(S[I], SLL); + LL := Space(L[I], LLL); + Line := SL + ' ' + LL + ' '+ D[I]; + if Length(Line) > MaxLineWidth then + begin + LineSize:=MaxLineWidth; + Gap := 0; + repeat + J := LineSize; + //if J > Length(Line) then J := Length(Line); + while (J > 0){ and (Length(Line) > 0)} do + begin + if (Line[J] = ' ') or (J = 1) then + begin + LinePart := Copy(Line, 1, J); + LinePart := Space(LinePart, Length(LinePart)+Gap, True); + Delete(Line,1,J); + Result.Add(LinePart); + break; + end; + Dec(J); + end; + Gap := SLL+1+LLL+4; + LineSize := MaxLineWidth-(Gap); + until Length(Line) = 0; + end + else + Result.Add(Line); + end; + S.Free; + L.Free; + D.Free; + +end; + +end. + diff --git a/applications/gobject-introspection/gir2pascal.lpi b/applications/gobject-introspection/gir2pascal.lpi index 1960d9639..5c5fa2ce4 100644 --- a/applications/gobject-introspection/gir2pascal.lpi +++ b/applications/gobject-introspection/gir2pascal.lpi @@ -30,11 +30,11 @@ - + - + @@ -75,10 +75,25 @@ + + + + + + + + + + + + + + + - + @@ -86,12 +101,6 @@ - - - - - - diff --git a/applications/gobject-introspection/gir2pascal.lpr b/applications/gobject-introspection/gir2pascal.lpr index ca4e6f022..d0b79559b 100644 --- a/applications/gobject-introspection/gir2pascal.lpr +++ b/applications/gobject-introspection/gir2pascal.lpr @@ -19,44 +19,53 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. program gir2pascal; {$mode objfpc}{$H+} +{ $DEFINE CreatePascalClasses} uses {$IFDEF UNIX}{$IFDEF UseCThreads} cthreads, {$ENDIF}{$ENDIF} - Classes, SysUtils, CustApp, DOM, XMLRead, girNameSpaces, girFiles, - girpascalwriter, girErrors, girCTypesMapping, girTokens, girObjects; + Classes, SysUtils,CommandLineOptions, DOM, XMLRead, girNameSpaces, girFiles, + girpascalwriter, girErrors, girCTypesMapping, girTokens, girObjects, + girPascalClassWriter, girpascalwritertypes{$IFDEF UNIX}, baseunix, termio{$ENDIF}; + type { TGirConsoleConverter } - TGirConsoleConverter = class(TCustomApplication) + TGirConsoleConverter = class private + FCmdOptions: TCommandLineOptions; FWriteCount: Integer; FPaths: TStringList; FOutPutDirectory : String; FFileToConvert: String; FOverWriteFiles: Boolean; - FWantTest: Boolean; - FDynamicLink: Boolean; + FOptions: TgirOptions; procedure AddDefaultPaths; procedure AddPaths(APaths: String); procedure VerifyOptions; procedure Convert; + // options + function CheckOptions: String; + //callbacks function NeedGirFile(AGirFile: TObject; NamespaceName: String) : TXMLDocument; // AName is the whole name unit.pas or file.c procedure WriteFile(Sender: TObject; AName: String; AStream: TStringStream); + procedure Terminate; protected - procedure DoRun; override; + procedure DoRun; //override; public - constructor Create(TheOwner: TComponent); override; + constructor Create; destructor Destroy; override; procedure WriteHelp; virtual; + procedure Run; end; + { TGirConsoleConverter } procedure TGirConsoleConverter.AddDefaultPaths; @@ -94,6 +103,12 @@ begin Terminate; Halt; end; + if FCmdOptions.HasOption('objects') and FCmdOptions.HasOption('classes') then + begin + WriteLn('Cannot use options ''--objects'' and ''--classes'' together!.'); + Terminate; + Halt; + end; end; function TGirConsoleConverter.NeedGirFile(AGirFile: TObject; NamespaceName: String): TXMLDocument; @@ -101,9 +116,11 @@ var Sr: TSearchRec; Path: String; begin + WriteLn('Looking for gir file: ', NamespaceName); Result := nil; for Path in FPaths do begin + WriteLn('Looking in path: ', Path); if FindFirst(Path+NamespaceName+'.gir', faAnyFile, Sr) = 0 then begin ReadXMLFile(Result, Path+Sr.Name); @@ -111,6 +128,8 @@ begin end; FindClose(Sr); end; + if Result = nil then + WriteLn('Unable to find gir file: ',NamespaceName); end; procedure TGirConsoleConverter.WriteFile(Sender: TObject; AName: String; AStream: TStringStream); @@ -139,6 +158,11 @@ begin end; end; +procedure TGirConsoleConverter.Terminate; +begin + Halt(1); +end; + procedure TGirConsoleConverter.Convert; var Doc: TXMLDocument; @@ -154,7 +178,7 @@ begin girFile.ParseXMLDocument(Doc); Doc.Free; - Writer := TgirPascalWriter.Create(girFile.NameSpaces, FWantTest, FDynamicLink); + Writer := TgirPascalWriter.Create(girFile.NameSpaces, FOptions); Writer.OnUnitWriteEvent:= @WriteFile; Writer.GenerateUnits; @@ -165,44 +189,99 @@ begin WriteLn(Format('Converted %d file(s) in %f seconds',[FWriteCount, DateTimeToTimeStamp(EndTime).Time / 1000])); end; +function TGirConsoleConverter.CheckOptions: String; +begin + Result := ''; + //FCmdOptions.SetOptions(ShortOpts, LongOpts); + with FCmdOptions do + begin + AddOption(['h', 'help'], False ,'Show this help message.'); + AddOption(['i', 'input'], True ,'.gir filename to convert.'); + AddOption(['o', 'output-directory'], True ,'Directory to write the resulting .pas files to. If not specified then the current working directory is used.'); + AddOption(['D', 'dynamic'], False , 'Use unit dynlibs and link at runtime'); + {$IFDEF CreatePascalClasses} + AddOption(['s', 'seperate-units'], False ,'Creates seperate units for each gir file: (xConsts, xTypes, xFunctions, [xClasses, xObjects].'); + + AddOption(['C', 'classes'], False ,'Create Pascal classes that envelope/wrap the GObjects. Also forces ''-s'''); + AddOption(['O', 'objects'], False ,'OPTION NOT IMPLEMENTED YET. See Note below. '+ + 'Creates a seperate unit for pascal Objects (not classes). Forces ''-s'' '+ + 'Note: If -C or -O are not used then pascal Objects and consts '+ + 'are in a single unit.'); + {$ENDIF CreatePascalClasses} + AddOption(['w', 'overwrite-files'], False ,'If the output .pas file(s) already exists then overwrite them.'); + AddOption(['n', 'no-default'], False ,'/usr/share/gir-1.0 is not added as a search location for needed .gir files.'); + AddOption(['p', 'paths'], True ,'List of paths seperated by ":" to search for needed .gir files.'); + AddOption(['t', 'test'], False ,'Creates a test program per unit to verify struct sizes.'); + end; + FCmdOptions.ReadOptions; + if FCmdOptions.OptionsMalformed then + REsult := 'Error reading arguments'; +end; + procedure TGirConsoleConverter.DoRun; -var - ErrorMsg: String; begin // quick check parameters - ErrorMsg:=CheckOptions('hnp:o:i:wtD',['help','no-default','paths','output-directory', 'input', 'overwrite-files', 'test', 'dynamic']); - if ErrorMsg<>'' then begin - ShowException(Exception.Create(ErrorMsg)); - Terminate; - Exit; - end; + CheckOptions;//('hnp:o:i:wtDCsO',['help','no-default','paths','output-directory', 'input', 'overwrite-files', 'test', 'dynamic', 'classes', 'seperate-units', 'objects']); // parse parameters - if HasOption('h','help') then begin + if FCmdOptions.OptionsMalformed then + begin + WriteLn('See -h for options.'); + Terminate; + Halt; + + end; + + if FCmdOptions.HasOption('help') then begin WriteHelp; Terminate; Exit; end; - if not HasOption('n', 'no-default') then + if not FCmdOptions.HasOption('input') then + begin + WriteLn('No input file specified! See -h for options.'); + Terminate; + Halt; + end; + + if not FCmdOptions.HasOption('no-default') then AddDefaultPaths; - if HasOption('o', 'output-directory') then - FOutPutDirectory:=IncludeTrailingPathDelimiter(GetOptionValue('o', 'output-directory')) + if FCmdOptions.HasOption('output-directory') then + FOutPutDirectory:=IncludeTrailingPathDelimiter(FCmdOptions.OptionValue('output-directory')) else FOutPutDirectory:=IncludeTrailingPathDelimiter(GetCurrentDir); - FFileToConvert:=GetOptionValue('i','input'); + FFileToConvert:=FCmdOptions.OptionValue('input'); + AddPaths(ExtractFilePath(FFileToConvert)); - if HasOption('p', 'paths') then - AddPaths(GetOptionValue('p', 'paths')); + if FCmdOptions.HasOption('paths') then + AddPaths(FCmdOptions.OptionValue('paths')); - if HasOption('w', 'overwrite-files') then + if FCmdOptions.HasOption('overwrite-files') then FOverWriteFiles:=True; - FWantTest := HasOption('t', 'test'); + if FCmdOptions.HasOption('test') then + Include(FOptions, goWantTest); - FDynamicLink := HasOption('D', 'dynamic'); + if FCmdOptions.HasOption('dynamic') then + Include(FOptions, goLinkDynamic); + + if FCmdOptions.HasOption('classes') then + begin + Include(FOptions, goClasses); + Include(FOptions, goSeperateConsts); + end; + + if FCmdOptions.HasOption('objects') then + begin + Include(FOptions, goObjects); + Include(FOptions, goSeperateConsts); + end; + + if FCmdOptions.HasOption('seperate-units') then + Include(FOptions, goSeperateConsts); VerifyOptions; @@ -213,34 +292,62 @@ begin Terminate; end; -constructor TGirConsoleConverter.Create(TheOwner: TComponent); +constructor TGirConsoleConverter.Create; begin - inherited Create(TheOwner); + //inherited Create(TheOwner); + FCmdOptions := TCommandLineOptions.Create; FPaths := TStringList.Create; end; destructor TGirConsoleConverter.Destroy; begin FPaths.Free; + FCmdOptions.Free; inherited Destroy; end; procedure TGirConsoleConverter.WriteHelp; +var + {$IFDEF UNIX} + w: winsize; + {$ENDIF} + ConsoleWidth: Integer; begin + ConsoleWidth:=80; + {$IFDEF UNIX} + fpioctl(0, TIOCGWINSZ, @w); + ConsoleWidth:=w.ws_col; + {$ENDIF} + Writeln('Usage: ',ExtractFileName(ParamStr(0)),' [options] -i filename'); + WriteLn(FCmdOptions.PrintHelp(ConsoleWidth).Text); +{ Writeln(''); - writeln(' Usage: ',ExtractFileName(ExeName),' [options] -i filename'); + writeln(' Usage: ',ExtractFileName(ParamStr(0)),' [options] -i filename'); Writeln(''); Writeln(''); Writeln(' -i --input= .gir filename to convert.'); Writeln(' -o --output-directory= Directory to write the resulting .pas files to. If not'); + Writeln(' specified then the current working directory is used.'); WriteLn(' -D --dynamic Use unit dynlibs and link at runtime'); - Writeln(' specified then the current working directory is used.'); + WriteLn(' -s --seperate-units Creates seperate units for each gir file:'); + WriteLn(' (xConsts, xTypes, xFunctions, [xClasses, xObjects].'); + WriteLn(' -C --classes Create Pascal classes that envelope/wrap the GObjects.'); + WriteLn(' Also forces ''-s'''); + WriteLn(' -O --objects OPTION NOT IMPLEMENTED YET. See Note below'); + WriteLn(' Creates a seperate unit for pascal Objects (not classes). Forces ''-s'''); + WriteLn(' Note: If -C or -O are not used then pascal Objects and consts'); + WriteLn(' are in a single unit.'); Writeln(' -w --overwrite-files If the output .pas file(s) already exists then overwrite them.'); Writeln(' -n --no-default /usr/share/gir-1.0 is not added as a search location for '); - Writeln(' needed .gir files.'); + Writeln(' needed .gir files.'); Writeln(' -p --paths= List of paths seperated by ":" to search for needed .gir files.'); Writeln(' -t --test Creates a test program and a test c file per unit to verify struct sizes.'); Writeln(''); +} +end; +procedure TGirConsoleConverter.Run; +begin + DoRun; end; var @@ -249,7 +356,7 @@ var {$R *.res} begin - Application:=TGirConsoleConverter.Create(nil); + Application:=TGirConsoleConverter.Create; Application.Run; Application.Free; end. diff --git a/applications/gobject-introspection/girerrors.pas b/applications/gobject-introspection/girerrors.pas index 099b2f040..2753a2b4b 100644 --- a/applications/gobject-introspection/girerrors.pas +++ b/applications/gobject-introspection/girerrors.pas @@ -63,7 +63,7 @@ begin Exit; end; // if AType = geDebug then - //WriteLn(girErrorName[AType],': ', AMsg); + WriteLn(girErrorName[AType],': ', AMsg); end; diff --git a/applications/gobject-introspection/girnamespaces.pas b/applications/gobject-introspection/girnamespaces.pas index dcf312724..6d101c12c 100644 --- a/applications/gobject-introspection/girnamespaces.pas +++ b/applications/gobject-introspection/girnamespaces.pas @@ -482,7 +482,9 @@ begin if FPos > 0 then // type includes namespace "NameSpace.Type" begin NSString:=Copy(AName,1,FPos-1); - NS := (Owner As TgirNamespaces).FindNameSpace(NSString); + + //NS := (Owner As TgirNamespaces).FindNameSpace(NSString); + NS := TgirNamespaces(Owner).FindNameSpace(NSString); if NS = nil then girError(geError, 'Referenced Namespace "'+NSString+'" not found while looking for '+AName); AName := Copy(AName, FPos+1, Length(AName)); @@ -490,6 +492,7 @@ begin if NS <> Self then SearchOnly:=True; + //if NS <> Self then WriteLn('Self NS = ', NameSpace, ' Lookup NS = ', NS.NameSpace); Result := TGirBaseType(NS.Types.Find(AName)); if (Result <> nil) and (Result.ObjectType = otFuzzyType) and (TgirFuzzyType(Result).ResolvedType <> nil) then Result := TgirFuzzyType(Result).ResolvedType; diff --git a/applications/gobject-introspection/girobjects.pas b/applications/gobject-introspection/girobjects.pas index cc114895e..d487cc78a 100644 --- a/applications/gobject-introspection/girobjects.pas +++ b/applications/gobject-introspection/girobjects.pas @@ -726,7 +726,6 @@ var begin inherited Create(AOwner, ANode); FFields := TgirFieldsList.Create; - {$warning not implemented} Node := ANode.FirstChild; while Node <> nil do begin @@ -814,6 +813,9 @@ begin //NodeURL(ANode); //Node := TDomELement(ANode.FindNode('type')); Node := TDOMElement(ANode.FirstChild); + if Node = nil then + girError(geError, Format(geMissingNode,[ClassName, '', ANode.NodeName])); + while Node <> nil do begin // it's one or the other @@ -851,8 +853,25 @@ begin if (FVarType <> nil) {and (GirTokenNameToToken(ANode.NodeName) = gtArray)} then FVarType.ImpliedPointerLevel := PointerLevelFromVarName(CType); - if Token <> gtVarArgs then - FVarType.ImpliedPointerLevel:=PointerLevel; //only will grow + if (FVarType <> nil) and (Token <> gtVarArgs) then + FVarType.ImpliedPointerLevel:=PointerLevel; //only will grow + + if (FVarType = nil) and (Token <> gtVarArgs) then + begin + WriteLn('Vartype name = ',VarTypeName); + VarTypeName := ANode.NodeName; + Node := TDOMElement(Anode.ParentNode); + while Node <> nil do + begin + if node.InheritsFrom(TDOMElement) then + VarTypeName := Node.NodeName + '('+Node.GetAttribute('name')+')/'+ VarTypeName + else + VarTypeName := Node.NodeName + '/'+ VarTypeName; + Node := TDOMElement(Node.ParentNode); + end; + WriteLn('Vartype is nil when it shouldnt be! '+VarTypeName ); + raise Exception.Create('Vartype is nil when it shouldnt be! '); + end; FObjectType:=otTypeParam; end; @@ -1052,10 +1071,22 @@ end; constructor TgirAlias.Create(AOwner: TObject; ANode: TDomNode); var - Node: TDOMElement; + TmpNode, Node: TDOMElement; + NodePath: String; begin inherited Create(AOwner, ANode); Node := TDomELement(ANode.FindNode('type')); + TmpNode := Node; + while TmpNode <> nil do + begin + if TmpNode.InheritsFrom(TDOMElement) then + NodePath := TmpNode.NodeName + '('+TmpNode.GetAttribute('name')+')/'+ NodePath + else + NodePath := TmpNode.NodeName + '/'+ NodePath; + TmpNode := TDOMElement(TmpNode.ParentNode); + end; + + //WriteLn('ALIAS: ', Node.GetAttribute('name')+' ', NodePath); FForType := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), Node.GetAttribute('c:type')); FObjectType:=otAlias; end; diff --git a/applications/gobject-introspection/girpascalclasswriter.pas b/applications/gobject-introspection/girpascalclasswriter.pas new file mode 100644 index 000000000..1808cf261 --- /dev/null +++ b/applications/gobject-introspection/girpascalclasswriter.pas @@ -0,0 +1,42 @@ +{ + The purpose of this unit is to create native pascal classes that wrap gobjects in a comfortable and usable way. +} + + +unit girPascalClassWriter; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, girObjects, girpascalwriter, girpascalwritertypes; + +type + + { TGObjectClass } + + TGObjectClass = class + private + FParentGObjectClass: TGObjectClass; + FgirObject: TgirClass; + FPascalUnit: TPascalUnit; + public + constructor Create(AParentGObjectClass: TGObjectClass; AClass: TgirClass; APascalUnit: TPascalUnit); + property ParentGObjectClass: TGObjectClass read FParentGObjectClass; + end; + + +implementation + +{ TGObjectClass } + +constructor TGObjectClass.Create(AParentGObjectClass: TGObjectClass; AClass: TgirClass; APascalUnit: TPascalUnit); +begin + FParentGObjectClass := AParentGObjectClass; + FgirObject := AClass; + FPascalUnit:=APascalUnit; +end; + +end. + diff --git a/applications/gobject-introspection/girpascalwriter.pas b/applications/gobject-introspection/girpascalwriter.pas index c374e516c..4c1852607 100644 --- a/applications/gobject-introspection/girpascalwriter.pas +++ b/applications/gobject-introspection/girpascalwriter.pas @@ -23,10 +23,10 @@ unit girpascalwriter; interface uses - Classes, SysUtils, girNameSpaces, girObjects, girTokens, contnrs; + Classes, SysUtils,girNameSpaces, girpascalwritertypes; type - TgirWriteEvent = procedure (Sender: TObject; AUnitName: AnsiString; AStream: TStringStream) of object; + { TgirPascalWriter } @@ -36,2134 +36,42 @@ type FOnUnitWriteEvent: TgirWriteEvent; FNameSpaces: TgirNamespaces; FUnits: TList; - FWantTest: Boolean; - FLinkDynamic: Boolean; + FOptions: TgirOptions; public - constructor Create(ANameSpaces: TgirNamespaces; AWantTest: Boolean; ALinkDynamic: Boolean); + constructor Create(ANameSpaces: TgirNamespaces; AOptions: TgirOptions); procedure GenerateUnits; property OnUnitWriteEvent: TgirWriteEvent read FOnUnitWriteEvent write FOnUnitWriteEvent; property DefaultUnitExtension: String read FDefaultUnitExtension write FDefaultUnitExtension; // is .pas by default + property Units: TList read FUnits; end; implementation uses girCTypesMapping; -type - 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; - - { TPDeclarationVar } - - TPDeclarationVar = class(TPDeclarationWithLines) - function AsString: String; override; - end; - - { TPDeclarationFunctions } - - TPDeclarationFunctions = class(TPDeclarationWithLines) - private - FDynamicFunctions: Boolean; - public - constructor Create(ADynamicFunctions: Boolean); - 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; - FFunctionSection: TPDeclarationFunctions; - FUsesSection: TPUses; - public - constructor Create(AOwner: TObject; AUses: TPUses; ADynamicFunctions: Boolean); - destructor Destroy; override; - function AsString: String; override; - property UsesSection: TPUses read FUsesSection; - property ConstSection: TPDeclarationConst read FConstSection; - 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 } - - TPascalUnit = class - private - FDynamicLoadUnloadSection: TPCodeText; - FDynamicEntryNames: TStringList; - FLinkDynamic: Boolean; - FFinalizeSection: TPFinialization; - FImplementationSection: TPImplementation; - FInitializeSection: TPInitialize; - FInterfaceSection: TPInterface; - FLibName: String; - FNameSpace: TgirNamespace; - FWantTest: Boolean; - ProcessLevel: Integer; //used to know if to write forward definitions - //FTestCFile: TStringStream; - FTestPascalFile: TStringStream; - FTestPascalBody: TStringList; - function GetUnitName: String; - - // functions to ensure the type is being written in the correct declaration - function WantTypeSection: TPDeclarationType; - function WantConstSection: TPDeclarationConst; - 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; ADeclareType: Boolean = True); - 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): 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 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(ANameSpace: TgirNamespace; ALinkDynamic: Boolean; AWantTest: Boolean); - destructor Destroy; override; - procedure ProcessConsts(AList:TList); // of TgirBaseType descandants - procedure ProcessTypes(AList:TFPHashObjectList); // of TgirBaseType descandants - procedure ProcessFunctions(AList:TList);// of TgirFunction - procedure GenerateUnit; - function AsStream: TStringStream; - procedure Finish; - - property InterfaceSection: TPInterface read FInterfaceSection; - property ImplementationSection: TPImplementation read FImplementationSection; - property DynamicLoadUnloadSection: TPCodeText read FDynamicLoadUnloadSection; - property InitializeSection: TPInitialize read FInitializeSection; - property FinalizeSection: TPFinialization read FFinalizeSection; - property UnitName: String read GetUnitName; - property LibName: String read FLibName write FLibName; - property NameSpace: TgirNamespace read FNameSpace; - end; - -function IndentText(const AText: String; Spaces: Integer = 0; LineEndingCount: Integer = 1): String; -begin - SetLength(Result, Spaces); - FillChar(Result[1], Spaces, ' '); - Result := Result+AText; - if LineEndingCount > 0 then - begin - SetLength(Result, Length(Result)+Length(LineEnding)*LineEndingCount); - FillChar(Result[Length(AText)+Spaces+1], LineEndingCount, LineEnding); - end; -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; - -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; - 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+ - FDeclarations.AsString+ - FFunctionSection.AsString; -end; - -{ TPUnitPart } - -constructor TPUnitPart.Create(AOwner: TObject); -begin - FOwner := AOwner; -end; - -{ TPascalUnit } - -function TPascalUnit.GetUnitName: String; -begin - Result := CalculateUnitName(FNameSpace.NameSpace, FNameSpace.Version); -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 - - 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 <> NameSpace) then - Exit; // it's written in another Namespace - - if (AType.CType = '') then //(AType.Name = '') then - begin - WriteLn('WARNING: Type.Ctype undefined! : ', Atype.Name); - //Halt; - - end; - if ProcessLevel > 0 then - begin - WriteForwardDefinition(AType); - 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 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)); - WriteLn('Unknown Type: ', AType.ClassName); - 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 - CTypesType := LookupGTypeToCType(FuzzyType.CType); - if CTypesType <> '' then - begin - FuzzyType.TranslatedName:= CTypesType; - 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 FWantTest 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.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.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 - WriteLn('Warning: Forwards definitions already written for : ', Aitem.TranslatedName); - AItem.ForwardDefinitionWritten := True; - PTypes := MakePointerTypesForType(ATypeName, APointerLevel); - 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; -begin - 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; - CType: TGirBaseType = nil; -begin - ResolveTypeTranslation(AItem); - ResolveTypeTranslation(AItem.ForType); - - // some aliases are just for the parser to connect a name to an alias - if AItem.CType = '' then - Exit; - ResolvedForName := aItem.ForType.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.Writing < msWritten then - WantTypeSection.Lines.Add(IndentText(Aitem.TranslatedName+' = '+ ResolvedForName+';' ,2,0)); -end; - -procedure TPascalUnit.HandleCallback(AItem: TgirCallback); -var - TypeSect: TPDeclarationType; - CB: String; -begin - - TypeSect := WantTypeSection; - - CB := WriteCallBack(AItem, False); - - if AItem.Writing < msWritten then - TypeSect.Lines.Add(IndentText(CB,2,0)) -end; - -procedure TPascalUnit.HandleEnum(AItem: TgirEnumeration; ADeclareType: Boolean = True); -var - ConstSection: TPDeclarationConst; - Entry: String; - i: Integer; - CName: String; - TypeName: String; -begin - ResolveTypeTranslation(AItem); - - ConstSection := WantConstSection; - ConstSection.Lines.Add(''); - //ATK_HYPERLINK_IS_INLINE_ - if ADeclareType then - begin - // forces forward declarations to be written - ProcessType(AItem); - - TypeName := ': '+AItem.TranslatedName; - - // 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('const'); - end - else - TypeName:=''; - ConstSection.Lines.Add(IndentText('{ '+ AItem.CType + ' }',2,0)); - - 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_'; - Entry := CName + TypeName+ ' = ' + AItem.Members.Member[i]^.Value+';'; - ConstSection.Lines.Add(IndentText(Entry,2,0)); - end; - AItem.Writing:=msWritten; -end; - -procedure TPascalUnit.HandleBitfield(AItem: TgirBitField); -{ -const - TemplateLongWord = - '%s = packed object(TBitObject32)'+LineEnding+ - '%s'+LineEnding+ - 'end'; -var - Intf: TPDeclarationType; - CodeText: TPCodeText; - Code: TStringList; - PName: String; - Entry: String; - i: Integer; - VarType: String; - } -begin - HandleEnum(AItem, True); -(* - Intf := WantTypeSection; - CodeText := TPCodeText.Create; - ImplementationSection.Declarations.Add(CodeText); - Code := TStringList.Create; - - PName:=MakePascalTypeFromCType(AItem.CType); - - {case AItem.Bits of - //1..8: VarType:='Byte'; - //9..16: VarType:='Word'; - //0:; - //17..32: VarType:='LongWord'; - //33..64: VarType:='QWord'; - else - WriteLn('Bitfield <> 16bits'); - Halt; - end; - } - HandleEnum(AItem, False); - - VarType:='DWord'; - - Intf.Lines.Add(IndentText(PName+ ' = packed object(TBitObject32)',2,0)); - Intf.Lines.Add(IndentText('public',2,0)); - for i := 0 to AItem.Members.Count-1 do - begin - Entry := 'property '+ SanitizeName(AItem.Members.Member[i]^.Name) +': '+VarType+' index '+AItem.Members.Member[i]^.Value+' read GetBit write SetBit;'; - Intf.Lines.Add(IndentText(Entry, 4,0)); - end; - Intf.Lines.Add(IndentText('end;',2,0)); - Intf.Lines.Add(''); - - CodeText.Content:=Code.Text; - Code.Free; - *) -end; - -procedure TPascalUnit.HandleRecord(AItem: TgirRecord); -begin - 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; -begin - 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)); - WriteLn('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; -begin - WriteFunctionTypeAndReturnType(AItem, RoutineType, Returns); - Params := WriteFunctionParams(AItem.Params); - Postfix := ' external;';// '+UnitName+'_library;'; - FuncSect := WantFunctionSection; - if not FLinkDynamic 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 = ''; -begin - Result := ''; - // we skip deprecated functions - if AFunction.Deprecated then //and (CompareStr(AFunction.DeprecatedVersion, NameSpace.Version) >= 0) 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;'; - - // 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); - if Pos('array of const', Params) + Pos('va_list', Params) > 0 then - Prefix:='//'; - if not FLinkDynamic then - Postfix := ' external;'// '+UnitName+'_library;'; - else - PostFix := ''; - - // 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;'; - - // result will be written in the object declaration - Result := Entry; - - // now make sure the flat proc has all the params it needs - if AIsMethod then - begin - // methods do not include the first param for it's type so we have to add it - if Params <> '' then - Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1)+'; ' + Params - else - Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1); - end; - - - // write the flat c function that will be linked - if not FLinkDynamic 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; - FDynamicEntryNames.Add(AFunction.CIdentifier); - end; - - // takes care of 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 = '') then - WriteWrapperForObject(RoutineType, AItem.TranslatedName, 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; - 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 := Copy(Line, 1,FoundPos-1); - Exit; - end - else - if not SetFound then - begin - SetFound := Pos(LookingForSet+':', Line) > 0; - SetFound := SetFound or (Pos(LookingForSet+'(', Line) > 0); - // pascal properties cannot use functions for the set 'procedure' - SetFound := SetFound and (Pos('proecedure ', Line) > 0); - end; - if SetFound and GetFound 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=''; - begin - 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(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 HandleFieldType(Field: TGirBaseType; AFirstPass: Boolean; out AddedBitSizedType: Boolean); - var - SetFound: Boolean; - begin - 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 : TypeFuncs.Add(IndentText(WriteFunction(TgirFunction(Field), AItem, False, True, UnitFuncs, UsedNames),4,0)); - otMethod : TypeFuncs.Add(IndentText(WriteFunction(TgirFunction(Field), AItem, True, True, UnitFuncs, UsedNames),4,0)); - otConstructor:TypeFuncs.Add(IndentText(WriteFunction(TgirConstructor(Field), AItem, False, True, UnitFuncs, UsedNames),4,0)); - otProperty : TypeFuncs.Add(IndentText(WriteMethodProperty(TgirProperty(Field), GetTypeForProperty(TgirProperty(Field), SetFound), SetFound),4,0)); - else // case < - WriteLn('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)); - TypeDecl.Add(IndentText(SanitizeName(Field.Name, 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; external;'; - GetTypeTemplateDyn = '%s: function:%s; cdecl;'; - var - AType: 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 FLinkDynamic then - UnitFuncs.Add(Format(GetTypeTemplate, [AObj.GetTypeFunction, AType])) - else - begin - UnitFuncs.Add(Format(GetTypeTemplateDyn, [AObj.GetTypeFunction, AType])); - FDynamicEntryNames.Add(AObj.GetTypeFunction); - end; - end; - -var - TypeSect: TPDeclarationType; - AddedBitSizedType: Boolean; -begin - 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 - WriteLn('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 - WantFunctionSection.Lines.AddStrings(UnitFuncs); - UnitFuncs.Free; - TypeFuncs.Free; - -end; - -procedure TPascalUnit.HandleUnion(AItem: TgirUnion); -begin - ResolveTypeTranslation(AItem); - WantTypeSection.Lines.Add(WriteUnion(AItem, False, 2)); - -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; -begin - if AWantSelf then - begin - if AParams.Count = 0 then - CallParams:='@self' - else - CallParams:='@self, '; - end - else - CallParams:=''; - if (ARoutineType = 'function') or (ARoutineType='constructor') then - ResultStr := 'Result := '; - Params:=WriteFunctionParams(AParams, @Args); - CallParams:=CallParams+Args; - Code := TPCodeText.Create; - Code.Content := Format(Decl, [ARoutineType, AObjectName, AObjectFunctionName, ParenParams(Params), AFunctionReturns])+ - Format(Body, [ResultStr, Self.UnitName+'.'+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 - CBName:=MakePascalTypeFromCType(AItem.CType); - 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') 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): String; -var - i: Integer; - ArgName: String; - Dummy: Boolean; -begin - Result := ''; - if AArgs <> nil then - AArgs^ := ''; - for i := 0 to AParams.Count-1 do - begin - Result := Result+WriteParamAsString(AParams.Param[i], i, Dummy, @ArgName); - 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; -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 (ACTypeAsBackup = 'gpointer') and (TranslatedName <> '') and (TranslatedName <> 'gpointer') 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 - WriteLn('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(AParam: TgirTypeParam; AIndex: Integer; out ABitSizeSpecified: Boolean; AFirstParam: PString = nil; AExistingUsedNames: TStringList = nil): 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 - WriteLn('WARNING: Bits are Set to [ ',AParam.Bits,' ]for: ' ,PN+': '+PT); - PT +=' { ERROR : Bits are Set to [ '+IntToStr(AParam.Bits)+' ] }'; - end; - - end; - Result := 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(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(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 - WriteLn('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..30] 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'); - Name: String; - Sanity: Integer = 0; - Sucess: Boolean; - TestName: String; -begin - 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]); - - 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(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:= ABaseType.Name; - ABaseType.TranslatedName:=MakePascalTypeFromCType(RawName, 0); - end; -end; - -constructor TPascalUnit.Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean; AWantTest: Boolean); -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; - FWantTest:=AWantTest; - FLinkDynamic := ALinkDynamic; - FFinalizeSection := TPFinialization.Create(Self); - FImplementationSection := TPImplementation.Create(Self); - FInitializeSection := TPInitialize.Create(Self); - FInterfaceSection := TPInterface.Create(Self, TPUses.Create, FLinkDynamic); - FDynamicLoadUnloadSection := TPCodeText.Create; - FDynamicEntryNames := TStringList.Create; - FDynamicEntryNames.Sorted:=True; - FDynamicEntryNames.Duplicates := dupIgnore; - FNameSpace := ANameSpace; - if FWantTest then - begin - //FTestCFile := TStringStream.Create(''); - //FTestCFile.WriteString(Format(CBasic, [FNameSpace.CIncludeName])); - FTestPascalFile := TStringStream.Create(''); - FTestPascalFile.WriteString(Format(PBasic,[UnitName, UnitName, UnitName])); - FTestPascalFile.WriteString(GTypeSize); - FTestPascalBody := TStringList.Create; - FTestPascalBody.Add('begin'); - FTestPascalBody.Add(' g_type_init();'); - - end; - ResolveFuzzyTypes; - GenerateUnit; -end; - -destructor TPascalUnit.Destroy; -begin - if FWantTest then - begin - FTestPascalFile.Free; - //FTestCFile.Free; - FTestPascalBody.Free; - end; - FFinalizeSection.Free; - FImplementationSection.Free; - FInitializeSection.Free; - FInterfaceSection.Free; - FDynamicLoadUnloadSection.Free; - FDynamicEntryNames.Free; - - inherited Destroy; -end; - -procedure TPascalUnit.ProcessConsts(AList: TList); - function WriteConst(AConst: TgirConstant; Suffix: String = ''): String; - begin - if AConst.IsString then - Result := SanitizeName(AConst.Name) + Suffix+' = '+QuotedStr(AConst.Value)+';' - else - Result := SanitizeName(AConst.Name) + 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]); - //if Item.ClassType <> TgirConstant then ; // raise error - Entry := LowerCase(SanitizeName(Item.Name)); - - repeat - try - Consts.AddObject(Entry, TObject(PtrUInt(NewConst.Lines.Count))); - break; - except - Suffix := '__'+IntToStr(Sanity); - Entry := LowerCase(SanitizeName(Item.Name))+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]); - 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]); - HandleFunction(Func); - end; -end; - -procedure TPascalUnit.GenerateUnit; -var - i: Integer; - NS: TgirNamespace; - ImplementationUses: TPUses; -begin - for i := 0 to FNameSpace.RequiredNameSpaces.Count-1 do - begin - NS := TgirNamespace(FNameSpace.RequiredNameSpaces.Items[i]); - InterfaceSection.UsesSection.Units.Add(' '+CalculateUnitName(NS.NameSpace,NS.Version)); - end; - - if FLinkDynamic then - begin - ImplementationUses := TPUses.Create; - ImplementationUses.Units.Add('DynLibs'); - ImplementationSection.Declarations.Add(ImplementationUses); - end - else // Not linking dynamically - begin - i := Pos(',',NameSpace.SharedLibrary); - if i > 0 then - LibName:=Copy(NameSpace.SharedLibrary,1,i-1) - else - LibName:=NameSpace.SharedLibrary; - WantConstSection.Lines.Add(IndentText(UnitName+'_library = '''+LibName+''';', 2)); - 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. Do not Edit. }',0,1)); - Str.WriteString(IndentText('unit '+ UnitName+';',0,2)); - Str.WriteString(IndentText('{$MODE OBJFPC}{$H+}',0,2)); - Str.WriteString(IndentText('{$PACKRECORDS C}',0,1)); - //Str.WriteString(IndentText('{$BITPACKING ON}',0,1)); not needed since we set records that need it to bitpacked - //Str.WriteString(IndentText('{$CALLING CDECL}',0,2)); - Str.WriteString(IndentText('{$MODESWITCH DUPLICATELOCALS+}',0,2)); - - if not FLinkDynamic then - for i := 0 to Libs.Count-1 do - Str.WriteString(IndentText('{$LINKLIB '+Libs.Strings[i]+'}',0,1)); - - Libs.Free; - - Str.WriteString(InterfaceSection.AsString); - Str.WriteString(ImplementationSection.AsString); - - if FLinkDynamic 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.'); - - Result.Position:=0; -end; - -procedure TPascalUnit.Finish; -begin - if FWantTest then - begin - FTestPascalFile.WriteString(FTestPascalBody.Text); - FTestPascalFile.WriteString('end.'); - //FTestCFile.Position:=0; - FTestPascalFile.Position:=0; - end; -end; - -{ TPDeclarationList } - -function TPDeclarationList.GetDeclarations(AIndex: Integer): TPDeclaration; -begin - Result := TPDeclaration(Items[AIndex]); -end; - -function TPDeclarationList.AsString: String; -var - i: Integer; -begin - for i := 0 to Count-1 do - begin - Result := Result+Declarations[i].AsString+LineEnding; - end; -end; { TgirPascalWriter } -constructor TgirPascalWriter.Create(ANameSpaces: TgirNamespaces; AWantTest: Boolean; ALinkDynamic: Boolean); +constructor TgirPascalWriter.Create(ANameSpaces: TgirNamespaces; AOptions: TgirOptions); begin FNameSpaces := ANameSpaces; FUnits := TList.Create; FDefaultUnitExtension:='.pas'; - FWantTest:=AWantTest; - FLinkDynamic:=ALinkDynamic; + FOptions:=AOptions; end; procedure TgirPascalWriter.GenerateUnits; var i: Integer; - FUnit: TPascalUnit; + UnitGroup: TPascalUnitGroup; begin for i := 0 to FNameSpaces.Count-1 do begin WriteLn(Format('Converting %s', [FNameSpaces.NameSpace[i].NameSpace])); - FUnit := TPascalUnit.Create(FNameSpaces.NameSpace[i], FLinkDynamic, FWantTest); - FUnit.ProcessConsts(FNameSpaces.NameSpace[i].Constants); - FUnit.ProcessTypes(FNameSpaces.NameSpace[i].Types); - FUnit.ProcessFunctions(FNameSpaces.NameSpace[i].Functions); - FUnit.Finish; - FUnits.Add(FUnit); - FOnUnitWriteEvent(Self, FUnit.UnitName+FDefaultUnitExtension, FUnit.AsStream); - if FWantTest then - begin - FOnUnitWriteEvent(Self, FUnit.UnitName+'_test'+FDefaultUnitExtension, FUnit.FTestPascalFile); - //FOnUnitWriteEvent(Self, FUnit.UnitName+'_c_test.c', FUnit.FTestCFile); - end; + UnitGroup := TPascalUnitGroup.Create(Self, FNameSpaces.NameSpace[i], FOptions); + UnitGroup.GenerateUnits; end; end; diff --git a/applications/gobject-introspection/girpascalwritertypes.pas b/applications/gobject-introspection/girpascalwritertypes.pas new file mode 100644 index 000000000..fce0ae367 --- /dev/null +++ b/applications/gobject-introspection/girpascalwritertypes.pas @@ -0,0 +1,2400 @@ +unit girpascalwritertypes; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, girNameSpaces, girObjects, girTokens, contnrs; + +type + TgirOption = (goWantTest, goLinkDynamic, goSeperateConsts, goClasses, goObjects); + TgirOptions = set of TgirOption; + TgirWriteEvent = procedure (Sender: TObject; AUnitName: AnsiString; AStream: TStringStream) of object; + + 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; + + { TPDeclarationVar } + + TPDeclarationVar = class(TPDeclarationWithLines) + function AsString: String; override; + end; + + { TPDeclarationFunctions } + + TPDeclarationFunctions = class(TPDeclarationWithLines) + private + FDynamicFunctions: Boolean; + public + constructor Create(ADynamicFunctions: Boolean); + 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; + FFunctionSection: TPDeclarationFunctions; + FUsesSection: TPUses; + public + constructor Create(AOwner: TObject; AUses: TPUses; ADynamicFunctions: Boolean); + destructor Destroy; override; + function AsString: String; override; + property UsesSection: TPUses read FUsesSection; + property ConstSection: TPDeclarationConst read FConstSection; + 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; + 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); + destructor Destroy; override; + procedure GenerateUnits; + property UnitForType[AType: TPascalUnitType]: TPascalUnit read GetUnitForType; + end; + + + { TPascalUnit } + + TPascalUnit = class + private + FDynamicLoadUnloadSection: TPCodeText; + FDynamicEntryNames: TStringList; + 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; + + // functions to ensure the type is being written in the correct declaration + function WantTypeSection: TPDeclarationType; + function WantConstSection: TPDeclarationConst; + 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; ADeclareType: Boolean = True); + 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): 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 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); + destructor Destroy; override; + procedure ProcessConsts(AList:TList); // of TgirBaseType descandants + procedure ProcessTypes(AList:TFPHashObjectList); // of TgirBaseType descandants + procedure ProcessFunctions(AList:TList);// of TgirFunction + procedure GenerateUnit; + function AsStream: TStringStream; + procedure Finish; + + property InterfaceSection: TPInterface read FInterfaceSection; + property ImplementationSection: TPImplementation read FImplementationSection; + 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; + +function IndentText(const AText: String; Spaces: Integer = 0; LineEndingCount: Integer = 1): String; +begin + if AText = '' then + Exit(''); + SetLength(Result, Spaces); + FillChar(Result[1], Spaces, ' '); + Result := Result+AText; + if LineEndingCount > 0 then + begin + SetLength(Result, Length(Result)+Length(LineEnding)*LineEndingCount); + FillChar(Result[Length(AText)+Spaces+1], LineEndingCount, LineEnding); + end; +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; + +{ 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); +begin + FWriter := AWriter; + FNameSpace := ANameSpace; + FOptions := AOptions; + FUnits := TFPList.Create; + FSimpleUnit := ([goSeperateConsts, goClasses, goObjects] * AOptions ) = []; + + if FSimpleUnit then + begin + FUnits.Add(TPascalUnit.Create(Self, FNameSpace, FOptions, PascalUnitTypeAll)); + //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)); + if goClasses in FOptions then + FUnits.Add(TPascalUnit.Create(Self, FNameSpace, FOptions, [utClasses])) + else + FUnits.Add(TPascalUnit.Create(Self, FNameSpace, FOptions, [utObjects])) + 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; +var + PUnit: TPascalUnit; +begin + for Pointer(PUnit) in FUnits do + if Assigned(PUnit) then + PUnit.GenerateUnit; + UnitForType[utConsts].ProcessConsts(FNameSpace.Constants); + 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; + 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+ + FDeclarations.AsString+ + FFunctionSection.AsString; +end; + +{ TPUnitPart } + +constructor TPUnitPart.Create(AOwner: TObject); +begin + FOwner := AOwner; +end; + +{ TPascalUnit } + +function TPascalUnit.GetUnitName: String; +begin + Result := CalculateUnitName(FNameSpace.NameSpace, FNameSpace.Version); +end; + +function TPascalUnit.GetUnitFileName: String; +begin + Result := 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 + WriteLn('WARNING: Type.Ctype undefined! : ', Atype.Name); + //Halt; + + end; + if ProcessLevel > 0 then + begin + WriteForwardDefinition(AType); + 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 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)); + WriteLn('Unknown Type: ', AType.ClassName); + 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 + CTypesType := LookupGTypeToCType(FuzzyType.CType); + if CTypesType <> '' then + begin + FuzzyType.TranslatedName:= CTypesType; + 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.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.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 + WriteLn('Warning: Forwards definitions already written for : ', Aitem.TranslatedName); + AItem.ForwardDefinitionWritten := True; + PTypes := MakePointerTypesForType(ATypeName, APointerLevel); + 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; + CType: TGirBaseType = nil; + ProperUnit: TPascalUnit; +begin + ProperUnit := FGroup.GetUnitForType(utTypes); + if ProperUnit <> Self then begin + ProperUnit.HandleAlias(AItem); + Exit; + end; + ResolveTypeTranslation(AItem); + ResolveTypeTranslation(AItem.ForType); + + // some aliases are just for the parser to connect a name to an alias + if AItem.CType = '' then + Exit; + ResolvedForName := aItem.ForType.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.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; + +procedure TPascalUnit.HandleEnum(AItem: TgirEnumeration; ADeclareType: Boolean = True); +var + ConstSection: TPDeclarationConst; + Entry: String; + i: Integer; + CName: String; + TypeName: String; + ProperUnit: TPascalUnit; + +begin + ProperUnit := FGroup.GetUnitForType(utTypes); + if ProperUnit <> Self then begin + ProperUnit.HandleEnum(AItem, ADeclareType); + Exit; + end; + ResolveTypeTranslation(AItem); + + ConstSection := WantConstSection; + ConstSection.Lines.Add(''); + //ATK_HYPERLINK_IS_INLINE_ + if ADeclareType then + begin + // forces forward declarations to be written + ProcessType(AItem); + + TypeName := ': '+AItem.TranslatedName; + + // 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('const'); + end + else + TypeName:=''; + ConstSection.Lines.Add(IndentText('{ '+ AItem.CType + ' }',2,0)); + + 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_'; + Entry := CName + TypeName+ ' = ' + AItem.Members.Member[i]^.Value+';'; + ConstSection.Lines.Add(IndentText(Entry,2,0)); + end; + AItem.Writing:=msWritten; +end; + +procedure TPascalUnit.HandleBitfield(AItem: TgirBitField); +{ +const + TemplateLongWord = + '%s = packed object(TBitObject32)'+LineEnding+ + '%s'+LineEnding+ + 'end'; +var + Intf: TPDeclarationType; + CodeText: TPCodeText; + Code: TStringList; + PName: String; + Entry: String; + i: Integer; + VarType: String; + } +begin + HandleEnum(AItem, True); +(* + Intf := WantTypeSection; + CodeText := TPCodeText.Create; + ImplementationSection.Declarations.Add(CodeText); + Code := TStringList.Create; + + PName:=MakePascalTypeFromCType(AItem.CType); + + {case AItem.Bits of + //1..8: VarType:='Byte'; + //9..16: VarType:='Word'; + //0:; + //17..32: VarType:='LongWord'; + //33..64: VarType:='QWord'; + else + WriteLn('Bitfield <> 16bits'); + Halt; + end; + } + HandleEnum(AItem, False); + + VarType:='DWord'; + + Intf.Lines.Add(IndentText(PName+ ' = packed object(TBitObject32)',2,0)); + Intf.Lines.Add(IndentText('public',2,0)); + for i := 0 to AItem.Members.Count-1 do + begin + Entry := 'property '+ SanitizeName(AItem.Members.Member[i]^.Name) +': '+VarType+' index '+AItem.Members.Member[i]^.Value+' read GetBit write SetBit;'; + Intf.Lines.Add(IndentText(Entry, 4,0)); + end; + Intf.Lines.Add(IndentText('end;',2,0)); + Intf.Lines.Add(''); + + CodeText.Content:=Code.Text; + Code.Free; + *) +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)); + WriteLn('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; + WriteFunctionTypeAndReturnType(AItem, RoutineType, Returns); + Params := WriteFunctionParams(AItem.Params); + Postfix := ' external;';// '+UnitName+'_library;'; + 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 = ''; + ProperUnit: TPascalUnit; + OptionsIndicateWrapperMethod: Boolean; +begin + Result := ''; + OptionsIndicateWrapperMethod:= FUnitType = PascalUnitTypeAll; + // we skip deprecated functions + if AFunction.Deprecated then //and (CompareStr(AFunction.DeprecatedVersion, NameSpace.Version) >= 0) 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;'; + + // 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); + if Pos('array of const', Params) + Pos('va_list', Params) > 0 then + Prefix:='//'; + if not (goLinkDynamic in FOptions) then + Postfix := ' external;'// '+UnitName+'_library;'; + else + PostFix := ''; + + // 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 then + Result := Entry + else + Result := ''; + + // now make sure the flat proc has all the params it needs + if AIsMethod then + begin + // methods do not include the first param for it's type so we have to add it + if Params <> '' then + Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1)+'; ' + Params + else + Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1); + 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 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)); + 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); + + 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 + OptionsIndicateWrapperMethod:=FUnitType = PascalUnitTypeAll; + if not OptionsIndicateWrapperMethod 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(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 TextIn <> '' then + AList.Add(TextIn); + end; + + procedure HandleFieldType(Field: TGirBaseType; AFirstPass: Boolean; out AddedBitSizedType: Boolean); + var + SetFound: Boolean; + PropType: String; + begin + 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 < + WriteLn('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)); + TypeDecl.Add(IndentText(SanitizeName(Field.Name, 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; external;'; + GetTypeTemplateDyn = '%s: function:%s; cdecl;'; + var + AType: 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 + UnitFuncs.Add(Format(GetTypeTemplate, [AObj.GetTypeFunction, AType])) + 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 + WriteLn('Unknown ObjectType : ', AObjectType); + Halt; + end; + if ProperUnit = nil then + begin + WriteLn('ProperUnit is not assigned! : ', 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 + WriteLn('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); + WantTypeSection.Lines.Add(WriteUnion(AItem, False, 2)); + +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; +begin + if AWantSelf then + begin + if AParams.Count = 0 then + CallParams:='@self' + else + CallParams:='@self, '; + end + else + CallParams:=''; + if (ARoutineType = 'function') or (ARoutineType='constructor') then + ResultStr := 'Result := '; + Params:=WriteFunctionParams(AParams, @Args); + 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 + CBName:=MakePascalTypeFromCType(AItem.CType); + 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') 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): String; +var + i: Integer; + ArgName: String; + Dummy: Boolean; +begin + Result := ''; + if AArgs <> nil then + AArgs^ := ''; + for i := 0 to AParams.Count-1 do + begin + Result := Result+WriteParamAsString(AParams.Param[i], i, Dummy, @ArgName); + 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; +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 (ACTypeAsBackup = 'gpointer') and (TranslatedName <> '') and (TranslatedName <> 'gpointer') 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 + WriteLn('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(AParam: TgirTypeParam; AIndex: Integer; out ABitSizeSpecified: Boolean; AFirstParam: PString = nil; AExistingUsedNames: TStringList = nil): 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 + WriteLn('WARNING: Bits are Set to [ ',AParam.Bits,' ]for: ' ,PN+': '+PT); + PT +=' { ERROR : Bits are Set to [ '+IntToStr(AParam.Bits)+' ] }'; + end; + + end; + Result := 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(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(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 + WriteLn('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..30] 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'); + Name: String; + Sanity: Integer = 0; + Sucess: Boolean; + TestName: String; +begin + 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]); + + 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(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:= ABaseType.Name; + ABaseType.TranslatedName:=MakePascalTypeFromCType(RawName, 0); + end; +end; + +constructor TPascalUnit.Create(AGroup: TPascalUnitGroup; ANameSpace: TgirNamespace; AOptions: TgirOptions; AUnitType: TPascalUnitTypes); +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; + 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();'); + + 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); + function WriteConst(AConst: TgirConstant; Suffix: String = ''): String; + begin + if AConst.IsString then + Result := SanitizeName(AConst.Name) + Suffix+' = '+QuotedStr(AConst.Value)+';' + else + Result := SanitizeName(AConst.Name) + 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]); + //if Item.ClassType <> TgirConstant then ; // raise error + Entry := LowerCase(SanitizeName(Item.Name)); + + repeat + try + Consts.AddObject(Entry, TObject(PtrUInt(NewConst.Lines.Count))); + break; + except + Suffix := '__'+IntToStr(Sanity); + Entry := LowerCase(SanitizeName(Item.Name))+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]); + 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]); + HandleFunction(Func); + end; +end; + +procedure TPascalUnit.GenerateUnit; +var + i: Integer; + NS: TgirNamespace; + ImplementationUses: TPUses; + NeedUnit: String; +begin + for i := 0 to FNameSpace.RequiredNameSpaces.Count-1 do + begin + NS := TgirNamespace(FNameSpace.RequiredNameSpaces.Items[i]); + NeedUnit:=CalculateUnitName(NS.NameSpace,NS.Version); + + 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 + i := Pos(',',NameSpace.SharedLibrary); + if i > 0 then + LibName:=Copy(NameSpace.SharedLibrary,1,i-1) + else + LibName:=NameSpace.SharedLibrary; + WantConstSection.Lines.Add(IndentText(UnitName+'_library = '''+LibName+''';', 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 '+ 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 + for i := 0 to Libs.Count-1 do + Str.WriteString(IndentText('{$LINKLIB '+Libs.Strings[i]+'}',0,1)); + + 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.'); + + Result.Position:=0; +end; + +procedure TPascalUnit.Finish; +begin + if (goWantTest in FOptions) then + begin + FTestPascalFile.WriteString(FTestPascalBody.Text); + FTestPascalFile.WriteString('end.'); + //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 + for i := 0 to Count-1 do + begin + Result := Result+Declarations[i].AsString+LineEnding; + end; +end; + + + + +end. + diff --git a/applications/gobject-introspection/girtokens.pas b/applications/gobject-introspection/girtokens.pas index 6bd381d67..0a527c718 100644 --- a/applications/gobject-introspection/girtokens.pas +++ b/applications/gobject-introspection/girtokens.pas @@ -81,7 +81,9 @@ implementation function GirTokenNameToToken(AName: String): TGirToken; begin for Result in TGirToken do - if GirTokenName[Result] = AName then + if GirTokenName[Result][1] <> AName[1] then + continue + else if GirTokenName[Result] = AName then Exit; Result := gtInvalid; end;