t_id
129
t_adddate
2003/10/03
t_result
0
t_knownrunerror
0
tr_id | run | tr_ok | tr_skip | tr_result |
---|---|---|---|---|
-682389287 | 750426 | True | False | Successfully run |
Record count: 1
{****************************************************************} { 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 }