Test suite results for test file test/cg/tcall1.pp

Test run data :

Test file "test/cg/tcall1.pp" information:

t_id 129
t_adddate 2003/10/03
t_result 0
t_knownrunerror 0

Detailed test run results:

Record count: 1

No log of 934959.

Source:

{****************************************************************}
{  CODE GENERATOR TEST PROGRAM                                   }
{  By Carl Eric Codere                                           }
{****************************************************************}
{ NODE TESTED : secondcalln()                                    }
{****************************************************************}
{ PRE-REQUISITES: secondload()                                   }
{                 secondassign()                                 }
{                 secondtypeconv()                               }
{                 secondtryexcept()                              }
{****************************************************************}
{ DEFINES:                                                       }
{            FPC     = Target is FreePascal compiler             }
{****************************************************************}
{ REMARKS: This tests secondcalln(), genentrycode() and          }
{ genexitcode().                                                 }
{                                                                }
{                                                                }
{****************************************************************}
program tcall;

{$ifdef fpc}{$mode objfpc}{$endif}
uses SysUtils;

{
class:
  class constructor
   1a  - success
   1b  - failure
  2 class destructor
  3 class method
  4 virtual method
  5 abstract method
  6 static method
object:
  object constructor
  7a  - success
  7b  - failure
  8 object destructor
  9 method
  10 virtual method
standard:
  11 function
  12 procedure
  13 procedure variable

modifiers:
  no parameters                    1a  1b
  parameters
     - const                       1a
     - value                       1a
     - variable                    1a
     - mixed                       1a

  explicit self parameter
  operator directive
  assembler directive
  interrupt directive
  inline directive
  cdecl directive
  pascal directive
  safecall directive
  stdcall directive
  popstack directive
  register directive
}

const
  GLOBAL_RESULT = $55;

var
 globalresult : integer;
 failed : boolean;

type

  tclass1 = class
    constructor create_none;               { class constructor }
    constructor create_value(l:longint;b: byte);
    constructor create_var(var l:longint;var b: byte);
    constructor create_const(const l:longint; const b: byte);
    constructor create_mixed(var a: byte; b: byte; var c: byte; const d: byte);
  end;

  tclass2 = class
    constructor create_none;               { class constructor }
  public
    b: array[1..$66666666] of byte;
  end;


  constructor tclass1.create_none;
   begin
     Inherited create;
     globalresult:=GLOBAL_RESULT;
   end;


  constructor tclass1.create_value(l:longint;b: byte);
   begin
     Inherited create;
     globalresult:=b;
   end;

  constructor tclass1.create_var(var l:longint;var b: byte);
    begin
     Inherited create;
      b:=GLOBAL_RESULT;
    end;

  constructor tclass1.create_const(const l:longint; const b: byte);
    begin
     Inherited create;
      globalresult := GLOBAL_RESULT;
    end;

  constructor tclass1.create_mixed(var a: byte; b: byte; var c: byte; const d: byte);
    begin
     Inherited create;
      globalresult := GLOBAL_RESULT;
    end;



  constructor tclass2.create_none;
   begin
     Inherited create;
     { the next line will normally not be reached, else
       it's a failure }
     globalresult:=0;
   end;



procedure fail;
begin
  WriteLn('Failure.');
  halt(1);
end;


function myheaperrornil(size : longint): integer;
  begin
    myheaperrornil:=1;
  end;

function myheaperrorexception(size : longint): integer;
  begin
    myheaperrorexception:=0;
  end;

var
 class_none: tclass1;
 class_value: tclass1;
 class_var: tclass1;
 class_const: tclass1;
 class_mixed: tclass1;
 class_none_fail : tclass2;
 a,b,c,d: byte;
 l:longint;
Begin
  { reset test variables }
  globalresult := 0;
  failed := false;

  write('class constructor testing...');
  { secondcalln : class constructor success }
  class_none:=tclass1.create_none;
  if globalresult <> GLOBAL_RESULT then
    failed:= true;

  globalresult := 0;
  class_value:=tclass1.create_value(0,GLOBAL_RESULT);
  if globalresult <> GLOBAL_RESULT then
    failed:= true;

  globalresult := 0;
  b:=0;
  class_var:=tclass1.create_var(l,b);
  globalresult:=b;
  if globalresult <> GLOBAL_RESULT then
    failed:= true;


  globalresult := 0;
  b:=GLOBAL_RESULT;
  class_const:=tclass1.create_const(l,b);
  if globalresult <> GLOBAL_RESULT then
    failed:= true;

  globalresult := 0;
  b:=0;
  a:=0;
  c:=0;
  d:=GLOBAL_RESULT;
  class_mixed:=tclass1.create_mixed(a,b,c,d);
  if globalresult <> GLOBAL_RESULT then
    failed:= true;

  globalresult := GLOBAL_RESULT;
  { secondcalln : class constructor failure, when getmem returns 0,
    that will call class_help_fail and abort class construction }
{$ifdef fpc}
  heaperror := @myheaperrornil;
  try
    class_none_fail:=tclass2.create_none;
   except
   on EOutOfMemory do globalresult:=0;
   end;
  if globalresult <> GLOBAL_RESULT then
    failed:= true;
{$endif fpc}

  globalresult := 0;
  { secondcalln : class constructor failure, getmem gives a runtime error
    that will be translated to a exception and the exception shall be catched
    here }
{$ifdef fpc}
  heaperror := @myheaperrorexception;
{$endif fpc}
  try
    class_none_fail:=tclass2.create_none;
   except
   on EOutOfMemory do globalresult:=GLOBAL_RESULT;
   end;
  if globalresult <> GLOBAL_RESULT then
    failed:= true;


  if failed then
    fail
  else
    WriteLn('Passed!');

end.

{
 $Log: tcall1.pp,v $
 Revision 1.4  2002/09/07 15:40:52  peter
   * old logs removed and tabs fixed

 Revision 1.3  2002/08/25 19:27:40  peter
   * failure test splitted for getmem reporting nil or a runtime error

 Revision 1.2  2002/04/02 17:05:17  peter
   * fix for non-fpc compilers

 Revision 1.1  2002/03/30 23:19:16  carl
 + secondcalln() : unfinished

}

Link to SVN view of test/cg/tcall1.pp source.