+ assigned testing

tests/test/units/system/tassignd.pp

@@ -0,0 +1,197 @@
+{ Copyright (c) Carl Eric Codere            }
+{ This program tests the assigned() routine }
+{ Tested against Delphi 6 Personal Edition  }
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+
+  tmyobject = object
+    procedure myroutine(x: byte);
+  end;
+  
+  tmyclass = class
+    procedure myroutine(x: byte);
+  end;
+  
+  
+  tobjectmethod = procedure (x: byte) of object;
+  tclassmethod = procedure (x: byte) of object;
+  tproc = procedure (x: byte);
+  
+  
+  type 
+    objpointer = packed record
+      _method : pointer;
+      _vmt : pointer;
+    end;
+  
+  
+  procedure fail; 
+   begin
+     WriteLn('Failure!');
+     halt(1);
+   end;
+  
+  procedure mydummyproc(x: byte);
+   begin
+   end;
+
+  function getpointer : pointer;
+   begin
+     getpointer := nil;
+   end;
+   
+  function getprocpointer : tproc;
+   begin
+     getprocpointer:=@mydummyproc;
+   end;
+   
+{$ifdef fpc}   
+  function getobjmethodpointer : tobjectmethod;
+   begin
+     getobjmethodpointer:[email protected];
+   end;
+
+  function getclamethodpointer : tclassmethod;
+   begin
+     getclamethodpointer:[email protected];
+   end;
+{$endif}   
+   
+  procedure tmyclass.myroutine(x: byte);
+   begin
+   end;
+   
+  procedure tmyobject.myroutine(x: byte);
+   begin
+   end;
+
+  { possible chocies (fixes branch only)  :
+      LOC_REGISTER
+      LOC_REFERENCE
+    second branch handles this in a generic way
+  }
+var
+  objmethod : tobjectmethod;
+  clamethod : tclassmethod;
+  proc : tproc;
+  p : pointer;
+  x: array[1..8] of integer;
+  _result : boolean;
+  myobject : tmyobject;
+  myclass : tmyclass;
+  ptrrecord : objpointer;
+Begin
+  myclass := tmyclass.create;
+  Write('Assigned(pointer) tests...');
+  _result := true;
+  p:=@x;
+  if not assigned(p) then
+    _result := false;
+  p:=nil;
+  if assigned(p) then
+    _result := false;
+{$ifdef fpc}    
+  if assigned(getpointer) then
+    _result := false;
+{$endif}    
+
+  if _result then
+    WriteLn('Success!')
+  else
+    fail;
+  {*******************************************************}    
+  Write('Assigned(proc) tests...');
+  _result := true;
+  proc:=@mydummyproc;
+  if not assigned(proc) then
+    _result := false;
+  proc:=nil;
+{$ifdef fpc}  
+  if assigned(proc) then
+    _result := false;
+  if not assigned(getprocpointer) then
+    _result := false;
+{$endif}    
+  if _result then
+    WriteLn('Success!')
+  else
+    fail;
+  {*******************************************************}    
+  Write('Assigned(object method) tests...');
+  _result := true;
+{$ifdef fpc}  
+  objmethod:[email protected];
+  if not assigned(objmethod) then
+    _result := false;
+{$endif}    
+  objmethod:=nil;
+  if assigned(objmethod) then
+    _result := false;
+  { lets put the individual fields to nil 
+    This is a hack which should never occur
+  }
+  objmethod:={$ifdef fpc}@{$endif}myobject.myroutine;
+  move(objmethod, ptrrecord, sizeof(ptrrecord));
+  ptrrecord._vmt := nil;
+  move(ptrrecord, objmethod, sizeof(ptrrecord));
+  if not assigned(objmethod) then
+    _result := false;
+
+  objmethod:={$ifdef fpc}@{$endif}myobject.myroutine;
+  move(objmethod, ptrrecord, sizeof(ptrrecord));
+  ptrrecord._method := nil;
+  move(ptrrecord, objmethod, sizeof(ptrrecord));
+  if assigned(objmethod) then
+    _result := false;
+
+{$ifdef fpc}
+  if not assigned(getobjmethodpointer) then
+    _result := false;
+{$endif}    
+  
+  if _result then
+    WriteLn('Success!')
+  else
+    fail;
+  {*******************************************************}    
+  Write('Assigned(class method) tests...');
+  _result := true;
+{$ifdef fpc}  
+  clamethod:[email protected];
+  if not assigned(clamethod) then
+    _result := false;
+{$endif}    
+  clamethod:=nil;
+  if assigned(clamethod) then
+    _result := false;
+  { lets put the individual fields to nil 
+    This is a hack which should never occur
+  }
+  clamethod:={$ifdef fpc}@{$endif}myclass.myroutine;
+  move(clamethod, ptrrecord, sizeof(ptrrecord));
+  ptrrecord._vmt := nil;
+  move(ptrrecord, clamethod, sizeof(ptrrecord));
+  if not assigned(clamethod) then
+    _result := false;
+
+  clamethod:={$ifdef fpc}@{$endif}myclass.myroutine;
+  move(clamethod, ptrrecord, sizeof(ptrrecord));
+  ptrrecord._method := nil;
+  move(ptrrecord, clamethod, sizeof(ptrrecord));
+  if assigned(clamethod) then
+    _result := false;
+
+{$ifdef fpc}
+  if not assigned(getclamethodpointer) then
+    _result := false;
+{$endif}    
+  
+  if _result then
+    WriteLn('Success!')
+  else
+    fail;
+    
+end.