Can't make this generic class factory work:
{
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; version 2 of the License.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
}
// Copyright (c) 2010 2011 2012 2013 2014 2015 - J. Aldo G. de Freitas Junior
{$mode objfpc}
{$H+}{$M+}
Unit
GenericClassFactory;
Interface
Uses
{$ifdef unix}
cthreads,
cmem,
{$endif}
SysUtils,
Contnrs,
RTTIObjects;
Type
EGenericClassFactory = Class(Exception);
Generic GGenericClassFactory<ObjectType> = Class
Type
TGenericType = ObjectType;
TGenericTypeClass = Class Of TGenericType;
Private
fMutex : TMultiReadExclusiveWriteSynchronizer;
fHashTable : TFPHashList;
Public
Constructor Create;
Destructor Destroy; Override;
Procedure Register(Const aClass : TClass; Const aName : String = '');
Function Build(Const aName : String): TGenericType;
End;
Implementation
Constructor GGenericClassFactory.Create;
Begin
Inherited;
fMutex := TMultiReadExclusiveWriteSynchronizer.Create;
fHashTable := TFPHashList.Create;
End;
Destructor GGenericClassFactory.Destroy;
Begin
FreeAndNil(fMutex);
FreeAndNil(fHashTable);
Inherited;
End;
Procedure GGenericClassFactory.Register(Const aClass : TClass; Const aName : String = '');
Begin
Try
fMutex.BeginWrite;
If aName = '' Then
fHashTable.Add(aClass.ClassName, Pointer(aClass))
Else
fHashTable.Add(aName, aClass);
Finally
fMutex.EndWrite;
End;
End;
Function GGenericClassFactory.Build(Const aName : String): TGenericType;
Var
lIndex : Integer;
Begin
Try
fMutex.BeginRead;
lIndex := fHashTable.FindIndexOf(aName);
If lIndex >= 0 Then
Begin
Build := TGenericTypeClass(fHashTable.Items[lIndex]).Create;
End
Else
Raise EGenericClassFactory.Create('Type ' + aName + ' is not registered in this class factory.');
Finally
fMutex.EndRead;
End;
End;
End.
Compiler claims :
Free Pascal Compiler version 2.6.4 [2014/03/06] for i386
Copyright (c) 1993-2014 by Florian Klaempfl and others
Target OS: Win32 for i386
Compiling CustomActorMessages.pas
Compiling GenericClassFactory.pas
GenericClassFactory.pas(37,23) Error: class type expected, but got "<undefined type>"
GenericClassFactory.pas(48,1) Fatal: There were 1 errors compiling module, stopping
Fatal: Compilation aborted
Tried using both TGenericTypeClass as type coercion and (TClass.Create As ObjectType) to no avail. Both give the same error. A generic class factory that does not return the correct type is not very useful.
Error at the line TGenericTypeClass = Class Of TGenericType;.
You can not declare class of for any ObjectType.
Simple code generates the same error:
type
generic TGenFoo<T> = class
type
TGenClass = class of T;
end;
Really, for T = integer declaration class of integer have no sense.
So you need to declare T with some restriction:
type
generic TGenFoo<T: TObject> = class
type
TGenClass = class of T;
end;
compiled fine.
FPC 3.1.1
Related
I'm attempting to create a class in Pascal, I am a bit confused about the declaration and syntax. the main thing is an error I'm getting "Forward declaration not solved Tetromino.Rotate(LongInt)", I read that I need to declare my procedure in the implementation section but I'm not sure where I'm meant to be putting that. also if you notice anything else wrong with my class declaration please tell me.
program Tetris;
{$MODE OBJFPC}
uses crt, sysutils;
type
Tetromino = class
private
TempFace : array [0..15] of char;
public
Face : array[0..15] of char;
//constructor create(); (idk what this is but read somewhere that you need it)
procedure Rotate(rotation : integer);
end;
var
a,b,c,d,e,f,g : tetromino;
begin
ReadKey();
end.
In a program module there is no need for division into interface and implementation. Therefore the error description (to implement the procedure in the implementation section) is a little bit misleading. Still, it indicates that the implementation of the Rotate() procedure is missing.
So, the error is that you have declared a procedure in the Tetromino class, but the implementation of that procedure is missing. You need to implement it somewhere between the class declaration and the begin .. end block of the program.
In a unit module, which has named sections: interface and implementation, you declare classes in the interface section (if those classes are to be accessible from other modules) and implement them in the implementation section.
In the following I outline what you need to do in your program, including the constructor for Tetromino
program Tetris;
{$MODE OBJFPC}
uses crt, sysutils;
type
Tetromino = class
private
TempFace : array [0..15] of char;
public
Face : array[0..15] of char;
constructor create(); (idk what this is but read somewhere that you need it)
procedure Rotate(rotation : integer);
end;
var
a,b,c,d,e,f,g : tetromino;
constructor Tetromino.create;
begin
// constructor (automatically) aquires a block of memory
// to hold members of the class
// to do: initialize member fields of the instance
end;
procedure Tetromino.Rotate(rotation: Integer);
begin
// implementation of the Rotate() method
end;
begin
ReadKey();
end.
I simplified the following code at the maximum to only show my problem.
When the destructor TClass3.Destroy is done, the action FreeAndNil(FClass3) causes a problem and the program stops. If have a look in the Heap.trc file I can read
Marked memory at $0000000001528FD0 invalid
Wrong signature $2951FD2D instead of 5C063D8B
program Project_testFree;
{$mode objfpc}{$H+}
uses
sysutils;
type
TClass1 = class
private
protected
public
constructor Create;
end;
TClass2 = class(TClass1)
private
protected
FTClass2 : cardinal;
public
end;
TClass3 = class
private
protected
FClass3 : TClass1;
public
constructor Create;virtual;
destructor Destroy;override;
end;
TClass4 = class(TClass3)
private
function GetLocalClass2: TClass2;
protected
public
constructor Create;override;
destructor destroy;override;
property pClass2:TClass2 read GetLocalClass2;
end;
constructor TClass1.Create;
begin
inherited;
end;
constructor TClass3.Create;
begin
FClass3 := TClass1.create;
end;
destructor TClass3.Destroy;
begin
FreeAndNil(FClass3);
writeln('Destroy');
inherited Destroy;
end;
constructor TClass4.Create;
begin
inherited Create;
pClass2.FTClass2 := 1;
end;
destructor TClass4.destroy;
begin
inherited destroy;
end;
function TClass4.GetLocalClass2: TClass2;
begin
result := TClass2(FClass3);
end;
var
c:TClass4;
begin
if FileExists('heap.trc') then
DeleteFile('heap.trc');
SetHeapTraceOutput('heap.trc');
c:=TClass4.Create;
c.free;
end.
I use Lazarus 1.6.2.
Thanks for your help.
You cast FClass3 to be TClass2. But you instantiated TClass1. The cast is therefore incorrect which would explain the error. Essentially, you lied to the compiler and it exacted its revenge.
Had you used a checked cast, using as, then a runtime error would have been raised.
I have made some very simple code in Pascal that is getting me this error:
Project BugFixing.exe raised exception class EAccessViolation with message 'Access violation at address 0040F1EE in module 'BugFixing.exe'. Write of address 00000004'.
The program consists of 2 modules:
BugFixing.dpr:
program BugFixing;
{$APPTYPE CONSOLE}
uses
SysUtils, uLinearProgrammingMainLogic in 'uLinearProgrammingMainLogic.pas', math;
var
MinOrMax : integer ;
Question : TQuestion ;
begin
try
Randomize ;
MinOrMax := RandomRange(0,2) ;
Question.SetMaximiseQuestion(MinOrMax);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
And uLinearProgrammingMainLogic.pas:
unit uLinearProgrammingMainLogic;
interface
uses sysUtils, math ;
type
TQuestion = class
private
MaximiseQuestion : boolean ;
public
procedure SetMaximiseQuestion (MinOrMax : integer) ;
end;
implementation
procedure TQuestion.SetMaximiseQuestion(MinOrMax : integer);
begin
if MinOrMax = 0 then
MaximiseQuestion := true
else
MaximiseQuestion := false ;
end;
end.
If anyone could explain to me why this is creating an access violation, that'd be appreciated. Thanks in advance. :)
A class must always be instantiated (TClassType.create) before use. The only exception to that are class/static methods, but you don't declare them that way (and that is not basic usage anyway)
I am trying to add NSStatusItem in a Delphi application for OSX. Searched for sample code to help me with that but got stuck when defining an interface:
Here is the code:
// Source: https://forums.embarcadero.com/thread.jspa?threadID=108449
unit Unit2;
interface
uses Macapi.ObjectiveC, Macapi.CocoaTypes, Macapi.Foundation, Macapi.AppKit,
Macapi.Helpers, Macapi.ObjcRuntime, System.TypInfo, FMX.Platform, FMX.Platform.Mac;
type
TFMXTrayItem = class(TOCLocal)
private
NSStatItem : NSStatusItem;
public
constructor Create;
destructor Destroy; override;
function GetObjectiveCClass: PTypeInfo; override;
procedure call_mymethod; cdecl;
end;
implementation
constructor TFMXTrayItem.Create;
var
NSContMenu : NSMenu;
NSContItem : NSMenuItem;
NSStatBar : NSStatusBar;
NSImg : NSImage;
AppBundle : NSBundle;
NSpImg: Pointer;
Path: String;
begin
inherited Create;
NSStatBar := TNSStatusBar.Create;
NSStatBar := TNSStatusBar.Wrap(TNSStatusBar.OCClass.systemStatusBar);
NSStatItem:= NSStatBar.statusItemWithLength(NSVariableStatusItemLength);
NSStatItem.setTarget(GetObjectID);
// Create context menu
NSContMenu := TNSMenu.Create;
NSContMenu := TNSMenu.Wrap(NSContMenu.initWithTitle(StrToNSStr('The caption')));
NSContItem:=TNSMenuItem.Create;
NSContItem:=TNSMenuItem.Wrap(NSContItem.initWithTitle(StrToNSStr('1. menuitem'),sel_getUid(PAnsiChar('call_mymethod')),StrToNSStr('')));
NSContItem.setTarget(GetObjectID);
NSContMenu.addItem(NSContItem);
NSContItem.release;
// Add menu
NSStatItem.retain;
NSStatItem.setHighlightMode(true);
NSStatItem.setMenu(NSContMenu);
NSContMenu.release;
// Get path to dir
AppBundle := TNSBundle.Wrap(TNSBundle.OCClass.mainBundle);
Path:=AppBundle.bundlePath.UTF8String+'/Contents/yourimage16x16.png';
NSpImg := TNSImage.Alloc.initWithContentsOfFile(StrToNSStr(Path));
// Create Icon
NSImg := TNSImage.Create;
NSImg := TNSImage.Wrap(NSpImg);
NSStatItem.setImage(NSImg);
NSImg.release;
end;
destructor TFMXTrayItem.Destroy;
begin
NSStatItem.release;
inherited;
end;
function TFMXTrayItem.GetObjectiveCClass: PTypeInfo;
begin
Result :=TypeInfo(IFMXTrayItem);
end;
procedure TFMXTrayItem.call_properties;
begin
// your event code of the menu item
end;
end.
Does anyone have any idea on how to declare the IFMXTrayItem interface?
Got it to work like this:
type
IFMXTrayItem = interface(NSObject)
['{7d2e4b38-61d9-4cf4-b78b-5f7c4188e9c0}']
procedure call_mymethod; cdecl;
end;
later edit:
Added a GUID to the interface after reading this:
This GUID is used by the compiler to identify uniquely this interface.
Strictly speaking, you can use an interface without the GUID, but you
can’t get very far using them as much of the RTL and most frameworks
that take advantage of interfaces will require that they have a GUID.
So that is a random GUID I generated but if you use this in your code you should generate your own GUID.
Uing the following class code in Lazarus I get the following error on the writeln(woman.name, 'has been born'); line: "Project My Application raised exception class 'External SIGSEV'. Other pascal code seems to work ok
program project1;
uses wincrt;
type human = class
private
health : integer;
public
name : string;
constructor born(n: string);
end;
constructor human.born(n: string);
begin
name := n;
health := 100;
end;
var
woman : human;
begin
woman.born('Tracy');
writeln(woman.name, 'has been born');
end.
You need to instantiate object this way:
woman := human.born('Tracy');