* patch from Martin Schreiber to fix bug #4247

git-svn-id: trunk@784 -

.gitattributes

@@ -6155,6 +6155,7 @@ tests/webtbs/tw4199.pp svneol=native#text/plain
 tests/webtbs/tw4202.pp svneol=native#text/plain
 tests/webtbs/tw4215.pp svneol=native#text/plain
 tests/webtbs/tw4233.pp svneol=native#text/plain
+tests/webtbs/tw4247.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain
 tests/webtbs/uw0555.pp svneol=native#text/plain

rtl/inc/heap.inc

@@ -1208,16 +1208,13 @@ begin
        We first check if the blocks after the current block are free. If not then we
        simply call getmem/freemem to get the new block }
      if check_concat_free_chunk_forward(pcurr,size) then
-       begin
-         try_concat_free_chunk_forward(pcurr);
-         currsize := (pcurr^.size and sizemask);
-       end;
+       repeat
+         concat_two_blocks(pcurr,pmemchunk_var(pointer(pcurr)+currsize));
+         currsize := pcurr^.size and sizemask;
+       until currsize>=size
+     else
+       exit;
    end;
-
-  { not enough space? }
-  if size>currsize then
-    exit;
-
   { is the size smaller then we can adjust the block to that size and insert
     the other part into the freelist }
   if currsize>size then

tests/webtbs/tw4247.pp

@@ -0,0 +1,19 @@
+{ %OPT=-gh }
+{ Source provided for Free Pascal Bug Report 4247 }
+{ Submitted by "Martin Schreiber" on  2005-08-02 }
+{ e-mail:  }
+program project1;
+ //compile with -ghl
+var
+ po1,po2: pointer;
+begin
+ getmem(po1,500);
+ getmem(po2,500);
+ reallocmem(po1,400);
+ reallocmem(po1,300);
+ reallocmem(po1,200);
+ reallocmem(po1,400); //crash with error 204
+ reallocmem(po1,600);
+ freemem(po1,600);
+ freemem(po2,500);
+end.