Merged revisions 10311,10336-10337,10399,10405,10412,10420,10456,10464,10493-10494 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/trunk

........
r10311 | peter | 2008-02-12 18:30:00 +0100 (Tue, 12 Feb 2008) | 2 lines

  * fix result type of constset+[]

........
r10336 | florian | 2008-02-16 09:53:54 +0100 (Sat, 16 Feb 2008) | 2 lines

* force ansistring concatenation when building stabs

........
r10337 | florian | 2008-02-16 09:55:08 +0100 (Sat, 16 Feb 2008) | 2 lines

* testcase for last commit

........
r10399 | jonas | 2008-02-27 22:17:13 +0100 (Wed, 27 Feb 2008) | 4 lines

  * use more generic set type boundaries for constant sets with one
    element in Delphi mode (fixes mantis #10890, but requires more
    thorough changes in nadd.pas for proper fixing)

........
r10405 | jonas | 2008-03-01 11:25:27 +0100 (Sat, 01 Mar 2008) | 7 lines

  * increase/decrease refcount of interface value parameters on procedure
    entry/exit (mantis #10897)
  * fixed tinterface2 which crashed after this change. It also crashed under
    Kylix: you cannot assign the result of an interfaced class to a class
    instance variable and then use it both as an interface (refcounted) and
    as class (non-refcounted)

........
r10412 | jonas | 2008-03-01 20:38:19 +0100 (Sat, 01 Mar 2008) | 4 lines

  * fixed overflow checking for $8000000000000000 in generic int64 mul
    routine (constants >high(int64) are currently always interpreted as
    int64 (and thus < 0) by the compiler if there is no explicit typecast)

........
r10420 | jonas | 2008-03-02 10:58:29 +0100 (Sun, 02 Mar 2008) | 2 lines

  + also test "pointer + integer" constant evaluation

........
r10456 | jonas | 2008-03-07 20:29:40 +0100 (Fri, 07 Mar 2008) | 5 lines

  * fixed "inherited some_property" constructs for getters/setters
    (mantis #10927)
  * extended the tb0259 test a bit (tests similar constructs in
    case there is no getter/setter)

........
r10464 | jonas | 2008-03-08 19:17:31 +0100 (Sat, 08 Mar 2008) | 3 lines

  - revert fix for #10927: the old behaviour was Delphi compatible,
    and the fix caused other problems (#10979)

........
r10493 | micha | 2008-03-15 21:18:28 +0100 (Sat, 15 Mar 2008) | 1 line

* add testcase of issue #11006 to testsuite
........
r10494 | jonas | 2008-03-16 00:20:11 +0100 (Sun, 16 Mar 2008) | 2 lines

  * fixed test

........

git-svn-id: branches/fixes_2_2@10527 -

.gitattributes

@@ -6690,6 +6690,7 @@ tests/tbs/tb0539.pp svneol=native#text/plain
 tests/tbs/tb0540.pp svneol=native#text/x-pascal
 tests/tbs/tb0541.pp svneol=native#text/plain
 tests/tbs/tb0542.pp svneol=native#text/plain
+tests/tbs/tb0545.pp svneol=native#text/plain
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
@@ -7558,6 +7559,7 @@ tests/webtbf/tw0896a.pp svneol=native#text/plain
 tests/webtbf/tw10425a.pp svneol=native#text/plain
 tests/webtbf/tw10457.pp svneol=native#text/plain
 tests/webtbf/tw10849.pp svneol=native#text/plain
+tests/webtbf/tw10890a.pp svneol=native#text/plain
 tests/webtbf/tw1157a.pp svneol=native#text/plain
 tests/webtbf/tw1238.pp svneol=native#text/plain
 tests/webtbf/tw1251a.pp svneol=native#text/plain
@@ -7899,10 +7901,15 @@ tests/webtbs/tw10800.pp svneol=native#text/plain
 tests/webtbs/tw1081.pp svneol=native#text/plain
 tests/webtbs/tw10815.pp svneol=native#text/plain
 tests/webtbs/tw10825.pp svneol=native#text/plain
+tests/webtbs/tw10890.pp svneol=native#text/plain
+tests/webtbs/tw10897.pp svneol=native#text/plain
 tests/webtbs/tw1090.pp svneol=native#text/plain
 tests/webtbs/tw1092.pp svneol=native#text/plain
+tests/webtbs/tw10927.pp svneol=native#text/plain
 tests/webtbs/tw1096.pp svneol=native#text/plain
 tests/webtbs/tw1097.pp svneol=native#text/plain
+tests/webtbs/tw10979.pp svneol=native#text/plain
+tests/webtbs/tw11006.pp svneol=native#text/plain
 tests/webtbs/tw1103.pp svneol=native#text/plain
 tests/webtbs/tw1104.pp svneol=native#text/plain
 tests/webtbs/tw1111.pp svneol=native#text/plain

compiler/dbgstabs.pas

@@ -1051,7 +1051,7 @@ implementation
                assigned(tprocdef(def.owner.defowner).procsym) then
               info := ','+GetSymName(def.procsym)+','+GetSymName(tprocdef(def.owner.defowner).procsym);
           end;
-        ss:='"'+obj+':'+RType+def_stab_number(def.returndef)+info+'",'+tostr(n_function)+',0,'+tostr(def.fileinfo.line)+','+def.mangledname;
+        ss:='"'+ansistring(obj)+':'+RType+def_stab_number(def.returndef)+info+'",'+tostr(n_function)+',0,'+tostr(def.fileinfo.line)+','+ansistring(def.mangledname);
         getmem(p,length(ss)+1);
         move(pchar(ss)^,p^,length(ss)+1);
         templist.concat(Tai_stab.Create(stab_stabs,p));

compiler/nadd.pas

@@ -699,8 +699,9 @@ implementation
              if (tsetdef(right.resultdef).settype=smallset) and
                 (tsetdef(left.resultdef).settype<>smallset) then
                right.resultdef:=tsetdef.create(tsetdef(right.resultdef).elementdef,0,255);
-             { check base types }
-             inserttypeconv(left,right.resultdef);
+             { check base types, keep the original type if right was an empty set }
+             if assigned(tsetdef(right.resultdef).elementdef) then
+               inserttypeconv(left,right.resultdef);
 
              if codegenerror then
               begin

compiler/ncgutil.pas

@@ -1188,13 +1188,12 @@ implementation
         if (tsym(p).typ=paravarsym) then
          begin
            needs_inittable :=
-             not is_class_or_interface(tparavarsym(p).vardef) and
+             not is_class(tparavarsym(p).vardef) and
              tparavarsym(p).vardef.needs_inittable;
            do_trashing :=
              (localvartrashing <> -1) and
              (not assigned(tparavarsym(p).defaultconstsym)) and
-             (not tparavarsym(p).vardef.needs_inittable or
-              is_class(tparavarsym(p).vardef));
+             not needs_inittable;
            case tparavarsym(p).varspez of
              vs_value :
                if needs_inittable then
@@ -1250,7 +1249,7 @@ implementation
         if not(tsym(p).typ=paravarsym) then
           exit;
         list:=TAsmList(arg);
-        if not is_class_or_interface(tparavarsym(p).vardef) and
+        if not is_class(tparavarsym(p).vardef) and
            tparavarsym(p).vardef.needs_inittable then
          begin
            if (tparavarsym(p).varspez=vs_value) then

compiler/ncnv.pas

@@ -295,7 +295,7 @@ implementation
         constsetlo,
         constsethi  : TConstExprInt;
 
-        procedure update_constsethi(def:tdef);
+        procedure update_constsethi(def:tdef; maybetruncenumrange: boolean);
           begin
             if (def.typ=orddef) and
                ((torddef(def).high>=constsethi) or
@@ -338,6 +338,16 @@ implementation
                    constsethi:=tenumdef(def).max;
                  if (tenumdef(def).min<=constsetlo) then
                    constsetlo:=tenumdef(def).min;
+                 { for constant set elements, delphi allows the usage of elements of enumerations which
+                   have value>255 if there is no element with a value > 255 used }
+                 if (maybetruncenumrange) and
+                    (m_delphi in current_settings.modeswitches) then
+                   begin
+                    if constsethi>255 then
+                      constsethi:=255;
+                    if constsetlo<0 then
+                      constsetlo:=0;
+                   end;
               end;
           end;
 
@@ -460,10 +470,10 @@ implementation
                               end
                              else
                               begin
-                                update_constsethi(p2.resultdef);
+                                update_constsethi(p2.resultdef,false);
                                 inserttypeconv(p2,hdef);
 
-                                update_constsethi(p3.resultdef);
+                                update_constsethi(p3.resultdef,false);
                                 inserttypeconv(p3,hdef);
 
                                 if assigned(hdef) then
@@ -480,21 +490,7 @@ implementation
                          if p2.nodetype=ordconstn then
                           begin
                             if not(is_integer(p2.resultdef)) then
-                              begin
-                                { for constant set elements, delphi allows the usage of elements of enumerations which
-                                  have value>255 if there is no element with a value > 255 used }
-                                if (m_delphi in current_settings.modeswitches) and (p2.resultdef.typ=enumdef) then
-                                  begin
-                                    if tordconstnode(p2).value>constsethi then
-                                      constsethi:=tordconstnode(p2).value;
-                                    if tordconstnode(p2).value<constsetlo then
-                                      constsetlo:=tordconstnode(p2).value;
-                                    if hdef=nil then
-                                      hdef:=p2.resultdef;
-                                  end
-                                else
-                                  update_constsethi(p2.resultdef);
-                              end;
+                              update_constsethi(p2.resultdef,true);
 
                             if assigned(hdef) then
                               inserttypeconv(p2,hdef)
@@ -506,7 +502,7 @@ implementation
                           end
                          else
                           begin
-                            update_constsethi(p2.resultdef);
+                            update_constsethi(p2.resultdef,false);
 
                             if assigned(hdef) then
                               inserttypeconv(p2,hdef)

rtl/inc/int64.inc

@@ -349,7 +349,7 @@
                 { the bit 63 can be only set if we have $80000000 00000000 }
                 { and sign is true                                         }
                 (q3 shr 63<>0) and
-                 ((q3<>(qword(1) shl 63)) or not(sign))
+                 ((q3<>qword(qword(1) shl 63)) or not(sign))
                 ) then
                 HandleErrorFrame(215,get_frame);
 

tests/tbs/tb0259.pp

@@ -5,18 +5,35 @@
 type
   c1=class
     Ffont : longint;
-    property Font:longint read Ffont;
+    property Font:longint read Ffont write Ffont;
   end;
 
   c2=class(c1)
     function GetFont:longint;
+    procedure setfont(l: longint);
   end;
 
 function c2.GetFont:longint;
 begin
-  result:=Font;
   result:=inherited Font;
 end;
 
+
+procedure c2.SetFont(l: longint);
+begin
+  inherited font := l;  
+end;
+
+var
+  c: c2;
 begin
+  c:=c2.create;
+  c.ffont:=5;
+  if c.getfont<>5 then
+    halt(1);
+  c.setfont(10);
+  if c.getfont<>10 then
+    halt(2);
+  if c.ffont<>10 then
+    halt(3);
 end.

tests/tbs/tb0545.pp

@@ -0,0 +1,25 @@
+{ %OPT=-gl -OG1 -S2cgi }
+program Project1;
+
+{$mode objfpc}{$H+}
+
+procedure my_very_looooooooong_idenfier_procedure_1;
+
+   procedure my_very_looooooooong_idenfier_procedure_2;
+
+     procedure my_very_looooooooong_idenfier_procedure_3;
+     begin
+        // bug
+     end;
+
+   begin
+     my_very_looooooooong_idenfier_procedure_3;
+   end;
+
+begin
+   my_very_looooooooong_idenfier_procedure_2;
+end;
+
+begin
+   my_very_looooooooong_idenfier_procedure_1;
+end.

tests/test/tinterface2.pp

@@ -1,6 +1,9 @@
 { %VERSION=1.1 }
 
+{$ifdef fpc}
 {$mode objfpc}
+{$endif}
+
 type
   ITest = interface(IUnknown)
     procedure DoSomething;
@@ -33,13 +36,12 @@ end;
 
 
 var
-  c: TMyClass;
+  c: ITest;
 begin
   i:=0;
   c := TMyClass.Create;
   DoTest(c);
   DoTest2(c);
-  c.Free;
   if i<>2 then
     begin
        writeln('Problem with passing interfaces as parameters');

tests/webtbf/tw10890a.pp

@@ -0,0 +1,82 @@
+{ %fail }
+
+program tester;
+
+{$mode delphi}
+
+type TXMLElemKind = (
+ elErrorFrm,
+ elInvolutiveness,
+ elIrreflexivity,
+ elIs,
+ elIt,
+ elIterEquality,
+ elIterStep,
+ elJustifiedProperty,
+ elJustifiedTheorem,
+ elLambdaVar,
+ elLet,
+ elLocusVar,
+ elMonomial,
+ elNot,
+ elPoweredVar,
+ elPred,
+ elPredInstance,
+ elPriority,
+ elPrivFunc,
+ elPrivPred,
+ elProjectivity,
+ elProof,
+ elTakeAsVar,
+ elTheorem,
+ elTheorems,
+ elThesis,
+ elThesisExpansions,
+ elTransitivity,
+ elTyp,
+ elUnexpectedProp,
+ elUniqueness,
+ elUnknownCorrCond,
+ elVar,
+ elVerum,
+ e34,e35,e36,e37,e38,e39,
+ e40, e41, e42, e43, e44, e45, e46, e47, e48, e49,
+ e50, e51, e52, e53, e54, e55, e56, e57, e58, e59,
+ e60, e61, e62, e63, e64, e65, e66, e67, e68, e69,
+ e70, e71, e72, e73, e74, e75, e76, e77, e78, e79,
+ e80, e81, e82, e83, e84, e85, e86, e87, e88, e89,
+ e90, e91, e92, e93, e94, e95, e96, e97, e98, e99,
+ e100, e101, e102, e103, e104, e105, e106, e107, e108, e109,
+ e110, e111, e112, e113, e114, e115, e116, e117, e118, e119,
+ e120, e121, e122, e123, e124, e125, e126, e127, e128, e129,
+ e130, e131, e132, e133, e134, e135, e136, e137, e138, e139,
+ e140, e141, e142, e143, e144, e145, e146, e147, e148, e149,
+ e150, e151, e152, e153, e154, e155, e156, e157, e158, e159,
+ e160, e161, e162, e163, e164, e165, e166, e167, e168, e169,
+ e170, e171, e172, e173, e174, e175, e176, e177, e178, e179,
+ e180, e181, e182, e183, e184, e185, e186, e187, e188, e189,
+ e190, e191, e192, e193, e194, e195, e196, e197, e198, e199,
+ e200, e201, e202, e203, e204, e205, e206, e207, e208, e209,
+ e210, e211, e212, e213, e214, e215, e216, e217, e218, e219,
+ e220, e221, e222, e223, e224, e225, e226, e227, e228, e229,
+ e230, e231, e232, e233, e234, e235, e236, e237, e238, e239,
+ e240, e241, e242, e243, e244, e245, e246, e247, e248, e249,
+ e250, e251, e252, e253, e254, e255, e256
+ );
+
+const TermElKinds = [
+ elVar
+ ];
+
+const FrmElKinds = [
+ elErrorFrm,
+ elIs,
+ elNot,
+ elPred,
+ elPrivPred,
+ elVerum,
+ e256
+ ];
+
+begin
+end.

tests/webtbs/tw10890.pp

@@ -0,0 +1,61 @@
+program tester;
+
+{$mode delphi}
+
+type TXMLElemKind = (
+ elErrorFrm,
+ elInvolutiveness,
+ elIrreflexivity,
+ elIs,
+ elIt,
+ elIterEquality,
+ elIterStep,
+ elJustifiedProperty,
+ elJustifiedTheorem,
+ elLambdaVar,
+ elLet,
+ elLocusVar,
+ elMonomial,
+ elNot,
+ elPoweredVar,
+ elPred,
+ elPredInstance,
+ elPriority,
+ elPrivFunc,
+ elPrivPred,
+ elProjectivity,
+ elProof,
+ elTakeAsVar,
+ elTheorem,
+ elTheorems,
+ elThesis,
+ elThesisExpansions,
+ elTransitivity,
+ elTyp,
+ elUnexpectedProp,
+ elUniqueness,
+ elUnknownCorrCond,
+ elVar,
+ elVerum
+ );
+
+const TermElKinds = [
+ elVar
+ ];
+
+const FrmElKinds = [
+ elErrorFrm,
+ elIs,
+ elNot,
+ elPred,
+ elPrivPred,
+ elVerum
+ ];
+
+var a:TXMLElemKind;
+
+begin
+  a:=elVerum;
+  if not(a in (FrmElKinds + TermElKinds)) then
+    halt(1);
+end.

tests/webtbs/tw10897.pp

@@ -0,0 +1,82 @@
+{ %opt=-gh }
+
+program aIntfTest;
+
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+{$APPTYPE CONSOLE}
+uses
+  SysUtils, Classes;
+ 
+ 
+type
+  IMyIntf = interface
+  ['{34326401-7B67-40FF-8E92-4587F65C8E24}']
+    function GetOwner: IMyIntf;
+    procedure Poing;
+  end;
+
+type
+  TMYClass = clasS(TinterfacedObject, IMyIntf)
+    fRef: Integer;
+  public
+    function GetOwner: IMyIntf;
+    function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
+    function _AddRef: Integer; stdcall;
+    function _Release: Integer; stdcall;
+    procedure Poing;
+  end;
+ 
+{ TMYClass }
+ 
+function TMYClass._AddRef: Integer;
+begin
+  inc(fRef);
+  result := fRef;
+  Writeln('AddRef:'+inttostr(result));
+end;
+ 
+function TMYClass._Release: Integer;
+begin
+  Dec(fRef);
+  result := FRef;
+  Writeln('Release:'+inttostr(result));
+  if result = 0 then Free;
+end;
+ 
+function TMYClass.GetOwner: IMyIntf;
+begin
+  Writeln('GetOwner1');
+  result := nil;
+  Writeln('GetOwner2');
+end;
+ 
+function TMYClass.QueryInterface(const IID: TGUID; out Obj): HRESULT;
+begin
+  if GetInterface(IID, Obj) then
+    result := S_OK else result := -1;
+end;
+ 
+var
+  r: IMyIntf;
+
+procedure Test(x: IMyIntf);
+begin
+  if x <> nil then x.Poing;
+  x := x.GetOwner;
+  if x <> nil then x.Poing;
+end;
+
+procedure TMYClass.Poing;
+begin
+  writeln('poing');
+end;
+
+begin
+  HaltOnNotReleased := true;
+  r := TMYClass.Create;
+  Test(r);
+  Writeln('nil');
+  r := nil; 
+end.

tests/webtbs/tw10927.pp

@@ -0,0 +1,59 @@
+{ %result=1 }
+
+program project1;
+
+{$mode objfpc}{$H+}
+
+type
+
+  { TOrgObject }
+
+  TOriginal=class
+  protected
+    procedure SetReadOnly(const AValue: boolean); virtual;
+  public
+    property readonly:boolean write SetReadOnly;
+  end;
+
+  { TDerived }
+
+  TDerived=class(TOriginal)
+  protected
+    procedure SetReadOnly(const AValue: boolean); override;
+  end;
+
+var
+ count1, count2: longint;
+
+{ TDerived }
+
+procedure TDerived.SetReadOnly(const AValue: boolean);
+begin
+  if (count2>0) then
+    halt(1);
+  inc(count2);
+  WriteLn('TDerived.SetReadOnly');
+  inherited;
+  inherited ReadOnly := AValue;
+end;
+
+{ TOrgObject }
+
+procedure TOriginal.SetReadOnly(const AValue: boolean);
+begin
+  if (count1>1) then
+    halt(2);
+  inc(count1);
+  WriteLn('TOriginal.SetReadOnly');
+end;
+
+var
+  D: TDerived;
+begin
+  D := TDerived.Create;
+  D.ReadOnly := True;
+  D.Free;
+  if (count1<>2) or
+     (count2<>1) then
+    halt(3);
+end.

tests/webtbs/tw10979.pp

@@ -0,0 +1,43 @@
+{$ifdef fpc}
+{$mode objfpc}
+{$endif fpc}
+
+uses Classes;
+
+{$ifndef fpc}
+type
+  ptruint = cardinal;
+{$endif}
+
+type
+  TMyStringList = class(TStringList)
+  private
+    function GetObjects(Index: Integer): TStringList;
+    procedure SetObjects(Index: Integer; const Value: TStringList);  
+  public
+    property Objects[Index: Integer]: TStringList read GetObjects write SetObjects;
+  end;
+
+function TMyStringList.GetObjects(Index: Integer): TStringList;
+begin
+  Result := TStringList(inherited Objects[Index]);
+end;
+
+procedure TMyStringList.SetObjects(Index: Integer; const Value: TStringList);
+begin
+  writeln('setobjects called');
+  inherited Objects[Index] := Value;
+end;
+
+              
+var
+  SL: TMyStringList;
+begin
+  SL := TMyStringList.Create;
+  SL.AddObject('Hello',SL);
+  WriteLn(SL[0],':',PtrUint(SL.Objects[0]),':',PtrUint(SL));
+  if (sl[0]<>'Hello') or
+     (PtrUint(SL.Objects[0])<>PtrUint(SL)) then
+    halt(1);
+end.
+

tests/webtbs/tw11006.pp

@@ -0,0 +1,39 @@
+{$mode objfpc}
+
+uses
+{$ifdef unix}
+  cthreads,
+{$endif}
+  sysutils,
+  classes;
+
+type
+  tmythread = class(tthread)
+    fs: ansistring;
+    constructor create(const s: ansistring);
+    procedure execute; override;
+  end;
+
+constructor tmythread.create(const s: ansistring);
+begin
+  fs:=s+'a';
+  freeonterminate:=true;
+  inherited create(true);
+end;
+
+procedure tmythread.execute;
+begin
+  sleep(60);
+  writeln('done');
+end;
+
+var
+  a: array[1..100] of tmythread;
+  i: longint;
+begin
+  for i:=low(a) to high(a) do
+    a[i]:=tmythread.create('b');
+  for i:=low(a) to high(a) do
+    a[i].resume;
+  sleep(60);
+end.

tests/webtbs/tw3073.pp

@@ -16,4 +16,6 @@ begin
    halt(1);
  if pwidechar(24)-pwidechar(22)<>1 then
   halt(1);
+ if pwidechar(22)+1 <> pwidechar(24) then
+   halt(1);
 end.

tests/webtbs/tw3964b.pp

@@ -1,7 +1,8 @@
+{ %needlibrary }
 { %target=linux }
 {$mode objfpc}
 
-{$linklib libtw3964a}
+{$linklib tw3964a}
 
 function testfunc : longint;
 begin