Permalink
Browse files

Correction du bug #805, avec l'ajout d'une propriété MetaClass dans T…

…SepiClass.
  • Loading branch information...
sjrd committed Sep 12, 2010
1 parent 1347f83 commit bc5970382dab291ca4cdfc0d28e1c8eeb4607d38
@@ -12,6 +12,8 @@ TPrintOnAddStrings = class(TStringList)
function Add(const Str: string): Integer; override;
procedure DynamicMethod; dynamic;
+
+ class procedure ShowClassName;
end;
implementation
@@ -32,6 +34,11 @@ procedure TPrintOnAddStrings.DynamicMethod;
Add('DynamicMethod entered');
end;
+class procedure TPrintOnAddStrings.ShowClassName;
+begin
+ WriteLn(ClassName);
+end;
+
procedure Test(const Str: string; Strings: TStrings);
var
Line: string;
@@ -144,6 +151,8 @@ procedure TestMethodRef;
TMonitor.Enter(Strings);
{$IFEND}
try
+ Strings.ShowClassName;
+
Add := Strings.Add;
for I := 1 to 3 do
@@ -113,8 +113,8 @@ constructor TOptions.Create;
{$IFEND}
FCacheDir := Dir+DefaultCacheDir;
- FOutputDir := Dir;
- FResourcesDir := Dir;
+ FOutputDir := '.\';
+ FResourcesDir := '.\';
// Create options
@@ -765,7 +765,6 @@ TSepiUnitCompiler = class(TSepiCompilerBase)
destructor Destroy; override;
function GetPointerType(PointTo: TSepiType): TSepiPointerType;
- function GetMetaClass(SepiClass: TSepiClass): TSepiMetaClass;
function GetMethodRefType: TSepiType;
function GetEmptySetType: TSepiType;
@@ -2836,28 +2835,6 @@ function TSepiUnitCompiler.GetPointerType(PointTo: TSepiType): TSepiPointerType;
PointerTypeName, PointTo);
end;
-{*
- Obtient un type meta-classe qui ne durera que la compilation
- @param SepiClass Classe dont obtenir une meta-classe
- @return Meta-classe de la classe
-*}
-function TSepiUnitCompiler.GetMetaClass(SepiClass: TSepiClass): TSepiMetaClass;
-var
- MetaClassName: string;
- I: Integer;
-begin
- MetaClassName := 'class$' + SepiClass.GetFullName;
- for I := 1 to Length(MetaClassName) do
- if MetaClassName[I] = '.' then
- MetaClassName[I] := '$';
-
- NeedCompileTimeTypes;
- Result := FCompileTimeTypes.GetComponent(MetaClassName) as TSepiMetaClass;
- if Result = nil then
- Result := TSepiMetaClass.Create(FCompileTimeTypes,
- MetaClassName, SepiClass);
-end;
-
{*
Obtient un type générique référence de méthode pour la compilation
@return Type générique référence de méthode
@@ -3236,7 +3236,7 @@ procedure TSepiMetaClassValue.Complete;
begin
Assert(SepiClass <> nil);
- SetValueType(UnitCompiler.GetMetaClass(SepiClass));
+ SetValueType(SepiClass.MetaClass);
end;
{*
@@ -6365,7 +6365,7 @@ procedure TSepiDereferenceValue.Complete;
if OpType is TSepiPointerType then
SetValueType(TSepiPointerType(OpType).PointTo)
else if OpType is TSepiClass then
- SetValueType(UnitCompiler.GetMetaClass(TSepiClass(OpType)))
+ SetValueType(TSepiClass(OpType).MetaClass)
else
MakeError(SPointerTypeRequired);
end;
@@ -100,6 +100,10 @@ interface
/// Types de signature avec un paramètre Self
skWithSelfParam = [skObjectProcedure..skClassDestructor];
+ /// Types de signature avec un paramètre Self métaclasse
+ skWithMetaClassSelfParam =
+ [skClassProcedure..skClassDestructor, skClassProperty];
+
type
{*
Type de paramètre caché
@@ -208,6 +212,7 @@ interface
TSepiSignature = class;
TSepiOverloadedMethod = class;
+ TSepiMetaClass = class;
/// Champ de classe
TSepiClassField = TSepiVariable;
@@ -865,8 +870,9 @@ TSepiIntfMethodRedirector = record
*}
TSepiClass = class(TSepiInheritableContainerType)
private
- FDelphiClass: TClass; /// Classe Delphi
- FParent: TSepiClass; /// Classe parent (nil si n'existe pas - TObject)
+ FDelphiClass: TClass; /// Classe Delphi
+ FParent: TSepiClass; /// Classe parent (nil si n'existe pas, TObject)
+ FMetaClass: TSepiMetaClass; /// Métaclasse par défaut
/// Interfaces supportées par la classe
FInterfaces: array of TSepiInterfaceEntry;
@@ -899,6 +905,8 @@ TSepiClass = class(TSepiInheritableContainerType)
procedure MakeDMT;
procedure MakeVMT;
+ procedure CreateMetaClass;
+
function GetInterfaceCount: Integer;
function GetInterfaces(Index: Integer): TSepiInterface;
@@ -1002,6 +1010,7 @@ TSepiClass = class(TSepiInheritableContainerType)
property DelphiClass: TClass read FDelphiClass;
property Parent: TSepiClass read FParent;
+ property MetaClass: TSepiMetaClass read FMetaClass;
property InterfaceCount: Integer read GetInterfaceCount;
property Interfaces[Index: Integer]: TSepiInterface read GetInterfaces;
@@ -1345,14 +1354,23 @@ constructor TSepiParam.CreateHidden(AOwner: TSepiSignature;
hpSelf:
begin
if Owner.Context is TSepiClass then
- FType := TSepiClass(Owner.Context)
- else if Owner.Context is TSepiRecordType then
begin
+ // Class
+ if Owner.Kind in skWithMetaClassSelfParam then
+ FType := TSepiClass(Owner.Context).MetaClass
+ else
+ FType := TSepiClass(Owner.Context);
+ end else if Owner.Context is TSepiRecordType then
+ begin
+ // Record
FKind := pkVar;
FByRef := True;
FType := TSepiRecordType(Owner.Context);
end else
+ begin
+ // Interface, method ref, etc.
FType := TSepiSystemUnit.Get(Owner.Root).TObject;
+ end;
end;
hpResult:
@@ -4074,6 +4092,7 @@ constructor TSepiClass.Load(AOwner: TSepiComponent; Stream: TStream);
else
FDelphiClass := nil;
OwningUnit.ReadRef(Stream, FParent);
+ OwningUnit.ReadRef(Stream, FMetaClass);
Stream.ReadBuffer(IntfCount, 4);
SetLength(FInterfaces, IntfCount);
@@ -4129,7 +4148,9 @@ constructor TSepiClass.Create(AOwner: TSepiComponent; const AName: string;
if Assigned(AParent) then
FParent := AParent
else
- FParent := (Root.SystemUnit as TSepiSystemUnit).TObject;
+ FParent := TSepiSystemUnit.Get(Self).TObject;
+
+ CreateMetaClass;
LoadInitialDataFromParent;
end;
@@ -4770,6 +4791,32 @@ procedure TSepiClass.MakeVMT;
MakeDMT;
end;
+{*
+ Crée la métaclasse par défaut
+*}
+procedure TSepiClass.CreateMetaClass;
+const
+ MetaClassName = '$MetaClass';
+var
+ I: Integer;
+ Component: TSepiComponent;
+begin
+ // Try and find an existing metaclass for this class
+ for I := Owner.ChildCount-1 downto 0 do
+ begin
+ Component := Owner.Children[I];
+ if (Component is TSepiMetaClass) and
+ (TSepiMetaClass(Component).SepiClass = Self) then
+ begin
+ FMetaClass := TSepiMetaClass(Component);
+ Exit;
+ end;
+ end;
+
+ // If none found, then create one
+ FMetaClass := TSepiMetaClass.Create(Self, MetaClassName, Self);
+end;
+
{*
Nombre d'interfaces supportées
@return Nombre d'interfaces supportées
@@ -4831,7 +4878,11 @@ procedure TSepiClass.ChildAdded(Child: TSepiComponent);
begin
inherited;
- if Child is TSepiField then
+ if Child is TSepiMetaClass then
+ begin
+ if (FMetaClass = nil) and (TSepiMetaClass(Child).SepiClass = Self) then
+ FMetaClass := TSepiMetaClass(Child);
+ end else if Child is TSepiField then
begin
with TSepiField(Child) do
if Offset + FieldType.Size > FInstSize then
@@ -4873,6 +4924,8 @@ procedure TSepiClass.ListReferences;
inherited;
OwningUnit.AddRef(FParent);
+ if FMetaClass.Owner <> Self then
+ OwningUnit.AddRef(FMetaClass);
for I := 0 to InterfaceCount-1 do
OwningUnit.AddRef(Interfaces[I]);
@@ -4895,8 +4948,14 @@ procedure TSepiClass.Save(Stream: TStream);
IntfCount, RedirectorCount, I: Integer;
begin
inherited;
+
OwningUnit.WriteRef(Stream, FParent);
+ if FMetaClass.Owner <> Self then
+ OwningUnit.WriteRef(Stream, FMetaClass)
+ else
+ OwningUnit.WriteRef(Stream, nil);
+
IntfCount := InterfaceCount;
Stream.WriteBuffer(IntfCount, 4);
for I := 0 to IntfCount-1 do

0 comments on commit bc59703

Please sign in to comment.