From bf8e5cd9dc4e881a337636047fb6cfc27a7b5f1f Mon Sep 17 00:00:00 2001
From: florian <florian@freepascal.org>
Date: Wed, 3 Aug 2005 20:01:49 +0000
Subject: [PATCH] Merged revisions 784 via svnmerge from /trunk

git-svn-id: branches/fixes_2_0@785 -
---
 .gitattributes         |  1 +
 rtl/inc/heap.inc       | 15 ++++++---------
 tests/webtbs/tw4247.pp | 19 +++++++++++++++++++
 3 files changed, 26 insertions(+), 9 deletions(-)
 create mode 100644 tests/webtbs/tw4247.pp

diff --git a/.gitattributes b/.gitattributes
index 780951ed52..93bd1df8dd 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -5987,6 +5987,7 @@ tests/webtbs/tw4188.pp svneol=native#text/plain
 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/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
diff --git a/rtl/inc/heap.inc b/rtl/inc/heap.inc
index 3fc5a61002..70f3236378 100644
--- a/rtl/inc/heap.inc
+++ b/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
diff --git a/tests/webtbs/tw4247.pp b/tests/webtbs/tw4247.pp
new file mode 100644
index 0000000000..db6610f6ed
--- /dev/null
+++ b/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.
\ No newline at end of file