소스 검색

--- Merging r21002 into '.':
U packages/fcl-image/src/fpwritepng.pp
--- Merging r21043 into '.':
U packages/opengl/src/glu.pp
--- Merging r21117 into '.':
U rtl/linux/Makefile.fpc
C rtl/linux/Makefile
--- Merging r21160 into '.':
U packages/fcl-json/examples/demortti.pp
--- Merging r21230 into '.':
U packages/fcl-fpcunit/src/consoletestrunner.pas
--- Merging r21241 into '.':
U packages/numlib/src/ipf.pas
Summary of conflicts:
Text conflicts: 1

# revisions: 21002,21043,21117,21160,21230,21241
r21002 | michael | 2012-04-23 11:42:34 +0200 (Mon, 23 Apr 2012) | 1 line
Changed paths:
M /trunk/packages/fcl-image/src/fpwritepng.pp

* Patch from Michalis Kamburelis to fix memory leak (bug 21835)
r21043 | marco | 2012-04-25 21:47:54 +0200 (Wed, 25 Apr 2012) | 2 lines
Changed paths:
M /trunk/packages/opengl/src/glu.pp

* Some minor changes that make the recent changes more backwards compatible. Mantis #21837
r21117 | florian | 2012-04-29 16:20:09 +0200 (Sun, 29 Apr 2012) | 2 lines
Changed paths:
M /trunk/rtl/linux/Makefile
M /trunk/rtl/linux/Makefile.fpc

* put types unit into a shared rtl
r21160 | michael | 2012-05-01 13:28:04 +0200 (Tue, 01 May 2012) | 1 line
Changed paths:
M /trunk/packages/fcl-json/examples/demortti.pp

* Remove linking of .res file (patch from Luiz Americo, bug #21908)
r21230 | michael | 2012-05-05 12:52:03 +0200 (Sat, 05 May 2012) | 1 line
Changed paths:
M /trunk/packages/fcl-fpcunit/src/consoletestrunner.pas

* Run test decorators when picking single tests below a testdecorator
r21241 | marco | 2012-05-05 22:20:43 +0200 (Sat, 05 May 2012) | 2 lines
Changed paths:
M /trunk/packages/numlib/src/ipf.pas

* helper procedure to calc min/max of a spline. Mantis #19669, Patch by A. Klenin.

git-svn-id: branches/fixes_2_6@21461 -

marco 13 년 전
부모
커밋
5c78929ac1

+ 59 - 6
packages/fcl-fpcunit/src/consoletestrunner.pas

@@ -69,6 +69,8 @@ type
 
 implementation
 
+uses testdecorator;
+
 const
   ShortOpts = 'alhp';
   DefaultLongOpts: array[1..8] of string =
@@ -268,13 +270,48 @@ begin
   inherited Destroy;
 end;
 
+Type
+  TTestDecoratorClass = Class of TTestDecorator;
+
+  { TDecoratorTestSuite }
+
+  TDecoratorTestSuite = Class(TTestSuite)
+    Procedure  FreeDecorators(T : TTest);
+    Destructor Destroy; override;
+  end;
+
+Procedure  TDecoratorTestSuite.FreeDecorators(T : TTest);
+
+Var
+  I : Integer;
+begin
+  If (T is TTestSuite) then
+    for I:=0 to TTestSuite(t).Tests.Count-1 do
+      FreeDecorators(TTest(TTestSuite(t).Tests[i]));
+  if (T is TTestDecorator) and (TTestDecorator(T).Test is TDecoratorTestSuite) then
+    T.free;
+end;
+
+{ TDecoratorTestSuite }
+
+destructor TDecoratorTestSuite.Destroy;
+begin
+  FreeDecorators(Self);
+  Tests.Clear;
+  inherited Destroy;
+end;
+
 procedure TTestRunner.DoRun;
 
+
   procedure CheckTestRegistry (test:TTest; ATestName:string; res : TTestSuite);
   var s, c : string;
       I, p : integer;
+      ds : TTestSuite;
+      D : TTestDecorator;
+
   begin
-    if test is TTestSuite then
+    if (test is TTestSuite) or (test is TTestDecorator) then
       begin
       p := pos ('.', ATestName);
       if p > 0 then
@@ -290,8 +327,25 @@ procedure TTestRunner.DoRun;
       if comparetext(c, test.TestName) = 0 then
         res.AddTest(test)
       else if (CompareText( s, Test.TestName) = 0) or (s = '') then
-        for I := 0 to TTestSuite(test).Tests.Count - 1 do
-          CheckTestRegistry (TTest(TTestSuite(test).Tests[I]), c, res)
+        begin
+        if (test is ttestsuite) then
+          begin
+          for I := 0 to TTestSuite(test).Tests.Count - 1 do
+             CheckTestRegistry (TTest((test as TTestSuite).Tests[I]), c, res)
+          end
+        else if (test is TTestDecorator) then
+          begin
+          DS:=TDecoratorTestSuite.Create;
+          CheckTestRegistry(TTest((test as TTestDecorator).Test), c, ds);
+          if (ds.CountTestCases>0) then
+            begin
+            D:=TTestDecoratorClass(Test.ClassType).Create(DS);
+            Res.AddTest(D);
+            end
+          else
+            DS.free;
+          end;
+        end;
       end
     else // if test is TTestCase then
       begin
@@ -303,7 +357,7 @@ procedure TTestRunner.DoRun;
 var
   I,P : integer;
   S : string;
-  TS : TTestSuite;
+  TS : TDecoratorTestSuite;
   
 begin
   S := CheckOptions(GetShortOpts, LongOpts);
@@ -331,7 +385,7 @@ begin
         writeln(GetTestRegistry[i].TestName)
     else
       begin
-        TS:=TTestSuite.Create('SuiteList');
+        TS:=TDecoratorTestSuite.Create('SuiteList');
         try
         while Not(S = '') Do
           begin
@@ -356,7 +410,6 @@ begin
           else
             Writeln('No tests selected.');  
         finally
-          TS.Tests.Clear;
           TS.Free;
         end;
       end;

+ 8 - 4
packages/fcl-image/src/fpwritepng.pp

@@ -36,6 +36,7 @@ type
       FTransparentColor : TFPColor;
       FSwitchLine, FCurrentLine, FPreviousLine : pByteArray;
       FPalette : TFPPalette;
+      OwnsPalette : boolean;
       FHeader : THeaderChunk;
       FGetPixel : TGetPixelFunc;
       FDatalineLength : longword;
@@ -115,6 +116,7 @@ end;
 
 destructor TFPWriterPNG.destroy;
 begin
+  if OwnsPalette then FreeAndNil(FPalette);
   with Fchunk do
     if acapacity > 0 then
       freemem (data);
@@ -407,13 +409,15 @@ begin
       c := 0;
     if FIndexed then
       begin
-      if TheImage.UsePalette then
-        FPalette := TheImage.Palette
-      else
+      if OwnsPalette then FreeAndNil(FPalette);
+      OwnsPalette := not TheImage.UsePalette;
+      if OwnsPalette then
         begin
         FPalette := TFPPalette.Create (16);
         FPalette.Build (TheImage);
-        end;
+        end
+      else
+        FPalette := TheImage.Palette;
       if ThePalette.count > 256 then
         raise PNGImageException.Create ('Too many colors to use indexed PNG color type');
       ColorType := 3;

+ 0 - 2
packages/fcl-json/examples/demortti.pp

@@ -5,8 +5,6 @@ program demortti;
 uses
   Classes, SysUtils, fpjson, fpjsonrtti, variants;
 
-{$R *.res}
-
 Var
   JS : TJSONStreamer;
 

+ 70 - 0
packages/numlib/src/ipf.pas

@@ -47,6 +47,11 @@ s calculated from x,y, with e.g. ipfisn}
 function  ipfspn(n: ArbInt; var x, y, d2s: ArbFloat; t: ArbFloat;
                  var term: ArbInt): ArbFloat;
 
+{Calculate minimum and maximum values for the n.c. spline d2s.
+Does NOT take source points into account.}
+procedure ipfsmm(n: ArbInt; var x, y, d2s, minv, maxv: ArbFloat; 
+        var term: ArbInt);
+
 {Calculate n-degree polynomal b for dataset (x,y) with m elements
  using the least squares method.}
 procedure ipfpol(m, n: ArbInt; var x, y, b: ArbFloat; var term: ArbInt);
@@ -653,6 +658,71 @@ begin
    end  { x[0] < t < x[n] }
 end; {ipfspn}
 
+procedure ipfsmm(
+  n: ArbInt; var x, y, d2s, minv, maxv: ArbFloat; var term: ArbInt);
+
+var
+  i: ArbInt;
+  h: ArbFloat;
+  px, py: ^arfloat0;
+  pd2s: ^arfloat1;
+
+  procedure UpdateMinMax(v: ArbFloat);
+  begin
+    if (0 >= v) or (v >= h) then exit;
+    v := ipfspn(n, x, y, d2s, px^[i]+v, term);
+    if v < minv then
+      minv := v;
+    if v > maxv then
+      maxv := v;
+  end;
+
+  procedure MinMaxOnSegment;
+  var
+    a, b, c: ArbFloat;
+    d: ArbFloat;
+  begin
+    h:=px^[i+1]-px^[i];
+    if i=0
+    then
+      begin
+        a:=pd2s^[1]/h/2;
+        b:=0;
+        c:=(py^[1]-py^[0])/h-h*pd2s^[1]/6;
+      end
+    else
+    if i=n-1
+    then
+      begin
+        a:=-pd2s^[n-1]/h/2;
+        b:=pd2s^[n-1];
+        c:=(py^[n]-py^[n-1])/h-h*pd2s^[n-1]/3;
+      end
+    else
+      begin
+        a:=(pd2s^[i+1]-pd2s^[i])/h/2;
+        b:=pd2s^[i];
+        c:=(py^[i+1]-py^[i])/h-h*(2*pd2s^[i]+pd2s^[i+1])/6;
+      end;
+    if a=0 then exit;
+    d := b*b-4*a*c;
+    if d<0 then exit;
+    d:=Sqrt(d);
+    UpdateMinMax((-b+d)/(2*a));
+    UpdateMinMax((-b-d)/(2*a));
+  end;
+
+begin
+  term:=1;
+  if n<2 then begin
+    term:=3;
+    exit;
+  end;
+  px:=@x; py:=@y; pd2s:=@d2s;
+  for i:=0 to n-1 do
+    MinMaxOnSegment;
+end;
+
 function p(x, a, z:complex): ArbFloat;
 begin
       x.sub(a);

+ 8 - 1
packages/opengl/src/glu.pp

@@ -83,6 +83,12 @@ Const
 {$ENDIF}
 {$endif}
                               
+type
+  TViewPortArray = array [0..3] of GLint;
+  T16dArray = array [0..15] of GLdouble;
+  T3dArray = array [0..2] of GLdouble;
+  T4pArray = array [0..3] of Pointer;
+  T4fArray = array [0..3] of GLfloat;
 
 const
   GLU_EXT_object_space_tess = 1;      
@@ -279,7 +285,7 @@ Type
   PGLdouble  = ^GLdouble;
   PGLfloat  = ^GLfloat;
   PGLint  = ^GLint;
-  PGLubyte  = ^GLubyte;
+  PGLubyte  = PAnsiChar; //< this is only used for strings in GLU
   PGLUnurbs  = ^GLUnurbs;
   PGLUquadric  = ^GLUquadric;
   PGLUtesselator  = ^GLUtesselator;
@@ -289,6 +295,7 @@ Type
   GLUtesselatorObj = GLUtesselator;
   GLUtriangulatorObj = GLUtesselator;
   _GLUfuncptr = procedure ;extdecl;
+  TCallback   =  _GLUfuncptr;
 
 {$IFDEF MORPHOS}
 

+ 2 - 2
rtl/linux/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2011/12/30]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/04/22]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-solaris x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded mipsel-linux
@@ -1832,7 +1832,7 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 override COMPILER_TARGETDIR+=.
 endif
-override SHARED_LIBUNITS=$(SYSTEMUNIT) objpas strings dos unix baseunix unixtype unixutil sysutils typinfo math $(CPU_UNITS) getopts errors sockets varutils classes fgl variants sysconst rtlconsts 
+override SHARED_LIBUNITS=$(SYSTEMUNIT) objpas strings dos unix baseunix unixtype unixutil sysutils typinfo math $(CPU_UNITS) getopts errors sockets varutils classes fgl variants sysconst rtlconsts types
 ifdef REQUIRE_UNITSDIR
 override UNITSDIR+=$(REQUIRE_UNITSDIR)
 endif

+ 1 - 1
rtl/linux/Makefile.fpc

@@ -45,7 +45,7 @@ libunits=$(SYSTEMUNIT) objpas strings dos \
       sysutils typinfo math \
       $(CPU_UNITS) getopts \
       errors sockets varutils \
-      classes fgl variants sysconst rtlconsts \
+      classes fgl variants sysconst rtlconsts types
 
 [prerules]
 RTL=..