Merged revisions 387,392,433,442,516 via svnmerge from

/trunk

git-svn-id: branches/fixes_2_0@534 -

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 }

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 }

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.

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')