paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-15 17:49:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* mark class and interface parameters as pfAddress (further fix for

Browse Source 
mantis #12038) + test

git-svn-id: trunk@12913 -
This commit is contained in:
Jonas Maebe 2009-03-17 20:37:11 +00:00
parent ebe8c60813
commit 9ab03e72f3
2 changed files with 142 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
compiler/ncgrtti.pas
View File

@ -630,6 +630,11 @@ implementation
} }
if is_open_array(parasym.vardef) then if is_open_array(parasym.vardef) then
paraspec:=paraspec or pfArray or pfReference; paraspec:=paraspec or pfArray or pfReference;
{ and these for classes and interfaces (maybe because they
are themselves addresses?)
}
if is_class_or_interface(parasym.vardef) then
paraspec:=paraspec or pfAddress;
{ set bits run from the highest to the lowest bit on { set bits run from the highest to the lowest bit on
big endian systems big endian systems
} }

223
tests/webtbs/tw12038.pp
View File

@ -14,19 +14,31 @@ uses
Classes; Classes;
type type
TMyObject = class;
TBatch = Procedure (Var S:String) of Object; stdcall; TBatch = Procedure (Var S:String) of Object; stdcall;
TProcess = function (Var S:String; const A:integer):int64 of Object; stdcall; TProcess = function (Var S:String; const A:integer):int64 of Object; stdcall;
TArray = function (Var Array1:Array of String; const P:Pointer; Out Out1:int64):int64 of Object; stdcall; TArray = function (Var Array1:Array of String; const P:Pointer; Out Out1:int64):int64 of Object; stdcall;
TOnFour = function (A: array of byte; const B: array of byte;
var C: array of byte; out D: array of byte): TComponent of object;
TOnFive = procedure (Component1: TComponent;
var Component2: TComponent;
out Component3: TComponent;
const Component4: TComponent) of object;
TOnSix = function (const A: string; var Two: integer;
out Three: TMyObject; Four: PInteger; Five: array of Byte;
Six: integer): string of object;
TMyObject=Class(TObject) TMyObject=Class(TObject)
private private
FFieldOne : Integer; FFieldOne : Integer;
FFieldTwo : String; FFieldTwo : String;
FOnBatch :TBatch; FOnBatch :TBatch;
FOnProcess : TProcess; FOnFour: TOnFour;
FOnArray: TArray; FOnFive: TOnFive;
FOnSix: TOnSix;
FOnProcess : TProcess;
FOnArray: TArray;
Procedure ProcNo1(Var S:String); stdcall; Procedure ProcNo1(Var S:String); stdcall;
Procedure ProcNo2(Var S:String); stdcall; Procedure ProcNo2(Var S:String); stdcall;
public public
@ -35,9 +47,20 @@ type
published published
Property FP2:String read FFieldTwo Write FFieldTwo ; Property FP2:String read FFieldTwo Write FFieldTwo ;
Property OnTraitement:TBatch read FOnBatch Write FOnBatch; Property OnTraitement:TBatch read FOnBatch Write FOnBatch;
Property OnProcess:TProcess read FOnProcess Write FOnProcess; Property OnProcess:TProcess read FOnProcess Write FOnProcess;
Property OnArray:TArray read FOnArray Write FOnArray; Property OnArray:TArray read FOnArray Write FOnArray;
function FourthPublished(A: array of byte; const B: array of byte;
var C: array of byte; out D: array of byte): TComponent;
procedure FifthPublished(Component1: TComponent;
var Component2: TComponent;
out Component3: TComponent;
const Component4: TComponent);
function SixthPublished(const A: string; var Two: integer;
out Three: TMyObject; Four: PInteger;
Five: array of Byte; Six: integer): string;
property OnFour: TOnFour read FOnFour write FOnFour;
property OnFive: TOnFive read FOnFive write FOnFive;
property OnSix: TOnSix read FOnSix write FOnSix;
end; end;
PShortString=^ShortString; PShortString=^ShortString;
@ -77,6 +100,25 @@ Begin
S:='The Batch execute the procedure TMyObject.ProcNo2'; S:='The Batch execute the procedure TMyObject.ProcNo2';
end; end;
function TMyObject.FourthPublished(A: array of byte; const B: array of byte;
var C: array of byte; out D: array of byte): TComponent;
begin
Result := nil;
end;
procedure TMyObject.FifthPublished(Component1: TComponent;
var Component2: TComponent;
out Component3: TComponent;
const Component4: TComponent);
begin
end;
function TMyObject.SixthPublished(const A: string; var Two: integer;
out Three: TMyObject; Four: PInteger;
Five: array of Byte; Six: integer): string;
begin
end;
Function BuildMethodDefinition(Liste: ParametersMethod1;NumI :Integer):String; Function BuildMethodDefinition(Liste: ParametersMethod1;NumI :Integer):String;
//Build the definition of method //Build the definition of method
var var
@ -197,61 +239,62 @@ begin
tkInteger : writeln('<tkinteger>'); tkInteger : writeln('<tkinteger>');
tkLString : writeln('<tklstring>'); tkLString : writeln('<tklstring>');
//tkString : writeln('Longueur max ='); string pascal max 255? //tkString : writeln('Longueur max ='); string pascal max 255?
tkMethod : Begin tkMethod :
writeln('>>> Methode Type >>>'); Begin
//Information for the method type : tkmethod writeln('>>> Methode Type >>>');
// TPropInfo.PropType= PPTypeInfo; //Information for the method type : tkmethod
// GetTypeData(TypeInfo: PTypeInfo) send PTypeData // TPropInfo.PropType= PPTypeInfo;
// PTypeData is for finding MethodKind // GetTypeData(TypeInfo: PTypeInfo) send PTypeData
// PTypeData is for finding MethodKind
{$IFDEF FPC} {$IFDEF FPC}
DTypeData:= GetTypeData(PTypeInfo(PropType)); DTypeData:= GetTypeData(PTypeInfo(PropType));
{$ELSE} {$ELSE}
DTypeData:= GetTypeData(PTypeInfo(PropType^)); DTypeData:= GetTypeData(PTypeInfo(PropType^));
{$ENDIF} {$ENDIF}
// Détermine le type de la méthode // Détermine le type de la méthode
Case DTypeData^.MethodKind of Case DTypeData^.MethodKind of
mkProcedure: PropTypeZ := 'procedure'; mkProcedure: PropTypeZ := 'procedure';
mkFunction: PropTypeZ := 'function'; mkFunction: PropTypeZ := 'function';
mkConstructor: PropTypeZ := 'constructor'; mkConstructor: PropTypeZ := 'constructor';
mkDestructor: PropTypeZ := 'destructor'; mkDestructor: PropTypeZ := 'destructor';
mkClassProcedure: PropTypeZ := 'class procedure'; mkClassProcedure: PropTypeZ := 'class procedure';
mkClassFunction: PropTypeZ := 'class function'; mkClassFunction: PropTypeZ := 'class function';
end; end;
Writeln('Number of Parameters : ',DTypeData^.ParamCount); Writeln('Number of Parameters : ',DTypeData^.ParamCount);
Writeln('Parameter List : ');//,DTypeData^.ParamList); Writeln('Parameter List : ');//,DTypeData^.ParamList);
{$IFDEF delphibuiltin} {$IFDEF delphibuiltin}
With DTypeData^ do With DTypeData^ do
SetArrayParameter(@DTypeData^.ParamList,ParamCount,MethodKind); SetArrayParameter(@DTypeData^.ParamList,ParamCount,MethodKind);
{$ELSE} {$ELSE}
//================================ //================================
Definition:='('; Definition:='(';
// Definition := Definition+'('; // Definition := Definition+'(';
CurrentParamPosition := 0; CurrentParamPosition := 0;
for i:= 1 to DTypeData^.ParamCount do for i:= 1 to DTypeData^.ParamCount do
begin begin
{ First Handle the ParamFlag } { First Handle the ParamFlag }
Flag:=byte(DTypeData^.ParamList[CurrentParamPosition]); Flag:=byte(DTypeData^.ParamList[CurrentParamPosition]);
Flags:=TParamFlags(Flag); Flags:=TParamFlags(Flag);
writeln('ord(Flags):',ord(DTypeData^.ParamList[CurrentParamPosition])); writeln('ord(Flags):',ord(DTypeData^.ParamList[CurrentParamPosition]));
// For i:= 1 to NumI do // For i:= 1 to NumI do
// begin // begin
if pfVar in Flags if pfVar in Flags
then Definition := Definition+('var '); then Definition := Definition+('var ');
if pfconst in Flags if pfconst in Flags
then Definition := Definition+('const '); then Definition := Definition+('const ');
if pfArray in Flags if pfArray in Flags
then Definition := Definition+('array of '); then Definition := Definition+('array of ');
if pfAddress in Flags if pfAddress in Flags
then Definition := Definition+('adresse ?'); // si Self ? then Definition := Definition+('adresse ?'); // si Self ?
if pfReference in Flags if pfReference in Flags
then Definition := Definition+('reference ?'); // ?? then Definition := Definition+('reference ?'); // ??
if pfout in Flags if pfout in Flags
then Definition := Definition+('out '); then Definition := Definition+('out ');
{ Next char is the length of the ParamName} { Next char is the length of the ParamName}
inc(CurrentParamPosition); inc(CurrentParamPosition);
ParamNameLength := ord( DTypeData^.ParamList[CurrentParamPosition]); ParamNameLength := ord( DTypeData^.ParamList[CurrentParamPosition]);
{ Next extract the Name of the Parameter } { Next extract the Name of the Parameter }
ParamName := ''; ParamName := '';
@ -268,52 +311,57 @@ begin
CurrentParamPosition := CurrentParamPosition + CurrentParamPosition := CurrentParamPosition +
ParamNameLength + 1; ParamNameLength + 1;
writeln('ParamName:',i,':', ParamName); writeln('ParamName:',i,':', ParamName);
writeln('TypeName:',i,':', TypeName); writeln('TypeName:',i,':', TypeName);
Definition := Format('%s%s: %s', [Definition, ParamName, TypeName]); Definition := Format('%s%s: %s', [Definition, ParamName, TypeName]);
If I<DTypeData^.ParamCount then Definition := Definition + '; ' If I<DTypeData^.ParamCount then Definition := Definition + '; '
end; end;
if DTypeData^.MethodKind = mkFunction then if DTypeData^.MethodKind = mkFunction then
begin begin
ParamNameLength := ord( DTypeData^.ParamList[CurrentParamPosition]); ParamNameLength := ord( DTypeData^.ParamList[CurrentParamPosition]);
Fu_ResultType := ''; Fu_ResultType := '';
for j := CurrentParamPosition + 1 to for j := CurrentParamPosition + 1 to CurrentParamPosition + ParamNameLength do
CurrentParamPosition + ParamNameLength do Fu_ResultType := Fu_ResultType + DTypeData^.ParamList[j];
Fu_ResultType := Fu_ResultType + end
DTypeData^.ParamList[j]; else
end Fu_ResultType:='';
else Fu_ResultType:=''; // end;
// end; Definition := Definition + ')';
Definition := Definition + ')'; if Fu_ResultType<>'' then
if Fu_ResultType<>'' then Definition := Format('%s: %s', [Definition, Fu_ResultType]);
Definition := Format('%s: %s', [Definition, Fu_ResultType]); Definition := Definition+' of object;';
Definition := Definition+' of object;';
//================================= //=================================
// Build the definion of method // Build the definion of method
Writeln(PropTypeZ+' '+Definition); Writeln(PropTypeZ+' '+Definition);
if ((PropTypeZ+' '+Definition) <> expectedresult) then if ((PropTypeZ+' '+Definition) <> expectedresult) then
halt(1); begin
writeln(expectedresult);
halt(1);
end;
{$ENDIF} {$ENDIF}
{$IFDEF delphibuiltin} {$IFDEF delphibuiltin}
Writeln(PropTypeZ+' '+BuildMethodDefinition(List_of_Param,DTypeData^.ParamCount)); Writeln(PropTypeZ+' '+BuildMethodDefinition(List_of_Param,DTypeData^.ParamCount));
{$ENDIF} {$ENDIF}
Method := GetMethodProp(OneObject, Informations.Name); Method := GetMethodProp(OneObject, Informations.Name);
if Method.Code <> NIL then if Method.Code <> NIL then
begin begin
Resultat:=''; Resultat:='';
TBatch(Method)(Resultat); TBatch(Method)(Resultat);
Writeln(Resultat); Writeln(Resultat);
end; end;
end; end;
end; end;
end; end;
end; end;
const const
expectedresults: array[0..3] of ansistring = ( expectedresults: array[0..6] of ansistring = (
'', '',
'function (out Out1: Int64; const P: Pointer; var array of reference ?Array1: AnsiString): Int64 of object;', 'function (out Out1: Int64; const P: Pointer; var array of reference ?Array1: AnsiString): Int64 of object;',
'procedure (adresse ?Component1: TComponent; var adresse ?Component2: TComponent; adresse ?out Component3: TComponent; const adresse ?Component4: TComponent) of object;',
'function (array of reference ?A: Byte; const array of reference ?B: Byte; var array of reference ?C: Byte; array of reference ?out D: Byte): TComponent of object;',
'function (const A: LongInt; var S: AnsiString): Int64 of object;', 'function (const A: LongInt; var S: AnsiString): Int64 of object;',
'function (const A: AnsiString; var Two: LongInt; adresse ?out Three: TMyObject; Four: PInteger; array of reference ?Five: Byte; Six: LongInt): AnsiString of object;',
'procedure (var S: AnsiString) of object;' 'procedure (var S: AnsiString) of object;'
); );
begin begin
@ -327,6 +375,9 @@ begin
{$ENDIF} {$ENDIF}
// Get list properties // Get list properties
NumI := GetPropList(TMyObject.ClassInfo, tkAny, @List_of_Prop); NumI := GetPropList(TMyObject.ClassInfo, tkAny, @List_of_Prop);
writeln('numi: ',numi);
if (numi<>length(expectedresults)) then
halt(44);
for I := 0 to NumI-1 do for I := 0 to NumI-1 do
begin begin
Writeln('Propriete ',I+1,' = ',List_of_Prop[I]^.Name); Writeln('Propriete ',I+1,' = ',List_of_Prop[I]^.Name);