From 0434d73f2bcf5b758593d762dedffcae6f85040f Mon Sep 17 00:00:00 2001 From: peter Date: Thu, 30 Jun 2005 06:54:58 +0000 Subject: [PATCH] Merged revisions 387,392,433,442,516 via svnmerge from /trunk git-svn-id: branches/fixes_2_0@534 - --- compiler/pdecobj.pas | 12 +++++++++ compiler/pinline.pas | 58 +++++++++++++++++++++++++++++++++++++++++- rtl/inc/macpas.pp | 46 +++++++++++++++++++++++++++++++++ tests/test/tmacpas2.pp | 29 ++++++++++++++++++--- 4 files changed, 140 insertions(+), 5 deletions(-) diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas index c860970d40..425d83932a 100644 --- a/compiler/pdecobj.pas +++ b/compiler/pdecobj.pas @@ -214,6 +214,11 @@ implementation begin readobjecttype:=true; + { MacPas object model is more like Delphi's than like TP's, but } + { uses the object keyword instead of class } + if (m_mac in aktmodeswitches) and + (token = _OBJECT) then + token := _CLASS; { distinguish classes and objects } case token of _OBJECT: @@ -591,6 +596,13 @@ implementation if assigned(pd) then begin parse_object_proc_directives(pd); + + { all Macintosh Object Pascal methods are virtual. } + { this can't be a class method, because macpas mode } + { has no m_class } + if (m_mac in aktmodeswitches) then + include(pd.procoptions,po_virtualmethod); + handle_calling_convention(pd); { add definition to procsym } diff --git a/compiler/pinline.pas b/compiler/pinline.pas index 458ff3e442..27bed0aab8 100644 --- a/compiler/pinline.pas +++ b/compiler/pinline.pas @@ -82,8 +82,64 @@ implementation set_varstate(p,vs_assigned,[]) else set_varstate(p,vs_used,[vsf_must_be_valid]); + if (m_mac in aktmodeswitches) and + is_class(p.resulttype.def) then + begin + classh:=tobjectdef(p.resulttype.def); + + if is_new then + begin + sym:=search_class_member(classh,'CREATE'); + p2 := cloadvmtaddrnode.create(ctypenode.create(p.resulttype));; + end + else + begin + sym:=search_class_member(classh,'FREE'); + p2 := p; + end; + + if not(assigned(sym)) then + begin + p.free; + if is_new then + p2.free; + new_dispose_statement := cerrornode.create; + consume_all_until(_RKLAMMER); + consume(_RKLAMMER); + exit; + end; + + do_member_read(classh,false,sym,p2,again,[]); + + { we need the real called method } + do_resulttypepass(p2); + + if (p2.nodetype=calln) and + assigned(tcallnode(p2).procdefinition) then + begin + if is_new then + begin + if (tcallnode(p2).procdefinition.proctypeoption<>potype_constructor) then + Message(parser_e_expr_have_to_be_constructor_call); + p2.resulttype:=p.resulttype; + p2:=cassignmentnode.create(p,p2); + resulttypepass(p2); + end + else + begin + { Free is not a destructor + if (tcallnode(p2).procdefinition.proctypeoption<>potype_destructor) then + Message(parser_e_expr_have_to_be_destructor_call); + } + end + end + else + internalerror(2005061202); + new_dispose_statement := p2; + end { constructor,destructor specified } - if try_to_consume(_COMMA) then + else if not(m_mac in aktmodeswitches) and + try_to_consume(_COMMA) then begin { extended syntax of new and dispose } { function styled new is handled in factor } diff --git a/rtl/inc/macpas.pp b/rtl/inc/macpas.pp index a1faabd115..3005871f06 100644 --- a/rtl/inc/macpas.pp +++ b/rtl/inc/macpas.pp @@ -14,6 +14,8 @@ **********************************************************************} +{$mode objfpc} + unit MacPas; interface @@ -38,6 +40,14 @@ function FOUR_CHAR_CODE(literal: string): LongWord; {$ifdef systeminline}inline; to emulate the behaviour of mac pascal compilers} operator := (s: ShortString) res: LongWord; {$ifdef systeminline}inline;{$endif} +{ Same as the "is" operator } +Function Member (Instance : TObject; AClass : TClass) : boolean; {$ifdef systeminline}inline;{$endif} + +function ord4(i: smallint): smallint; {$ifdef systeminline}inline;{$endif} +function ord4(l: longint): longint; {$ifdef systeminline}inline;{$endif} +function ord4(c: cardinal): cardinal; {$ifdef systeminline}inline;{$endif} +function ord4(p: pointer): ptrint; {$ifdef systeminline}inline;{$endif} + implementation @@ -57,4 +67,40 @@ begin res := PLongWord(@s[1])^; end; +Function Member (Instance : TObject; AClass : TClass) : boolean; {$ifdef systeminline}inline;{$endif} +begin + Result:=Instance is AClass; +end; + + +function ord4(i: smallint): smallint; {$ifdef systeminline}inline;{$endif} +begin + result:=i; +end; + + +function ord4(l: longint): longint; {$ifdef systeminline}inline;{$endif} +begin + result := l; +end; + + +function ord4(c: cardinal): cardinal; {$ifdef systeminline}inline;{$endif} +begin + result := c; +end; + + +function ord4(p: pointer): ptrint; {$ifdef systeminline}inline;{$endif} +begin + result := ptrint(p); +end; + + +{$ifdef powerpc} +begin + asm + mtfsfi 6,1 + end; +{$endif powerpc} end. diff --git a/tests/test/tmacpas2.pp b/tests/test/tmacpas2.pp index 6b882c03af..b08eb6b75d 100644 --- a/tests/test/tmacpas2.pp +++ b/tests/test/tmacpas2.pp @@ -7,6 +7,11 @@ program tmacpas2; var success: Boolean = true; +type + {Since we do not want to compile in the whole mac api, we + simulate decl of FourCharCode here:} + + MyFourCharCodeType = Longword; procedure Proc; @@ -15,16 +20,27 @@ begin Exit(Proc); end; -const - a = true; - b = true; - c = false; +procedure TestFourCharCode(myFCC: MyFourCharCodeType); + +begin + Writeln('FPC creator code as number: ', myFCC); + if myFCC <> $46506173 then + success := false; +end; + +const + myFCCconst = 'FPas'; {Free Pascals Creator code :) } var p: pointer; l,i: longint; + a,b,c : Boolean; begin + a := true; + b := true; + c := false; + {** Test & and | as alias for AND and OR **} if not (a & b) then success:= false; @@ -37,6 +53,7 @@ begin if l <> 4711 then success:= false; + {** Test cycle and leave **} i:= 0; while true do begin @@ -48,6 +65,10 @@ begin if i<> 2 then success:= false; + {** Does literal four char codes work**} + {Both directly and indirectly} + TestFourCharCode('FPas'); + TestFourCharCode(myFCCconst); if success then Writeln('Whole test succeded')