From a1bcc1c8d234e1edab09f2fc7345627e41338c42 Mon Sep 17 00:00:00 2001
From: Jonas Maebe <jonas@freepascal.org>
Date: Sun, 10 Jan 2010 15:36:23 +0000
Subject: [PATCH]   * turn openstring value parameters into regular shortstring
 parameters     (mantis #14940 and #14941)   * only turn var/our shortstring
 parameters with a length of 255 into     openstring parameters with {$p+}
 (new tbf/tb0217.pp)

git-svn-id: trunk@14602 -
---
 .gitattributes           |  3 +++
 compiler/pdecsub.pas     | 28 +++++++++++++++++++++++-----
 tests/tbf/tb0217.pp      | 17 +++++++++++++++++
 tests/webtbs/tw14941.pp  | 21 +++++++++++++++++++++
 tests/webtbs/tw14941a.pp | 24 ++++++++++++++++++++++++
 5 files changed, 88 insertions(+), 5 deletions(-)
 create mode 100644 tests/tbf/tb0217.pp
 create mode 100644 tests/webtbs/tw14941.pp
 create mode 100644 tests/webtbs/tw14941a.pp

diff --git a/.gitattributes b/.gitattributes
index 4b2322e554..86d2874b52 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -7708,6 +7708,7 @@ tests/tbf/tb0215c.pp svneol=native#text/plain
 tests/tbf/tb0215d.pp svneol=native#text/plain
 tests/tbf/tb0215e.pp svneol=native#text/plain
 tests/tbf/tb0216.pp svneol=native#text/plain
+tests/tbf/tb0217.pp svneol=native#text/plain
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
 tests/tbf/ub0158a.pp svneol=native#text/plain
@@ -10176,6 +10177,8 @@ tests/webtbs/tw14812.pp svneol=native#text/plain
 tests/webtbs/tw14841.pp svneol=native#text/plain
 tests/webtbs/tw1485.pp svneol=native#text/plain
 tests/webtbs/tw1489.pp svneol=native#text/plain
+tests/webtbs/tw14941.pp svneol=native#text/plain
+tests/webtbs/tw14941a.pp svneol=native#text/plain
 tests/webtbs/tw14958a.pp svneol=native#text/plain
 tests/webtbs/tw14958b.pp svneol=native#text/plain
 tests/webtbs/tw14992a.pp svneol=native#text/pascal
diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas
index ee9d8cfde9..4dff5ecce0 100644
--- a/compiler/pdecsub.pas
+++ b/compiler/pdecsub.pas
@@ -571,11 +571,29 @@ implementation
                   end;
 
                 { open string ? }
-                if (varspez in [vs_out,vs_var]) and
-                   (cs_openstring in current_settings.moduleswitches) and
-                   is_shortstring(hdef) then
-                  hdef:=openshortstringtype;
-
+                if is_shortstring(hdef) then
+                  begin
+                    case varspez of
+                      vs_var,vs_out:
+                        begin
+                          { not 100% Delphi-compatible: type xstr=string[255] cannot
+                            become an openstring there, while here it can }
+                          if (cs_openstring in current_settings.moduleswitches) and
+                             (tstringdef(hdef).len=255) then
+                            hdef:=openshortstringtype
+                        end;
+                      vs_value:
+                       begin
+                         { value "openstring" parameters don't make sense (the
+                            original string can never be modified, so there's no
+                            use in passing its original length), so change these
+                            into regular shortstring parameters (seems to be what
+                            Delphi also does) }
+                        if is_open_string(hdef) then
+                          hdef:=cshortstringtype;
+                       end;
+                    end;
+                  end;
                 if (target_info.system in [system_powerpc_morphos,system_m68k_amiga]) then
                   begin
                     if (idtoken=_LOCATION) then
diff --git a/tests/tbf/tb0217.pp b/tests/tbf/tb0217.pp
new file mode 100644
index 0000000000..7f4a578e94
--- /dev/null
+++ b/tests/tbf/tb0217.pp
@@ -0,0 +1,17 @@
+{ %fail }
+
+{$p+}
+{$v+}
+type
+  tstr = string[8];
+
+{ FPC used to convert the following parameter into an openstring }
+procedure test(var str: tstr);
+begin
+end;
+
+var
+  s: string[20];
+begin
+  test(s);
+end.
diff --git a/tests/webtbs/tw14941.pp b/tests/webtbs/tw14941.pp
new file mode 100644
index 0000000000..0fa248de87
--- /dev/null
+++ b/tests/webtbs/tw14941.pp
@@ -0,0 +1,21 @@
+program StringTest5;
+{$V+}
+var
+   s    :String;
+
+procedure P( s: OpenString);
+begin
+  writeln(s);
+  if (high(s)<>255) or
+     (s<>'12345') then
+    halt(1);
+end;
+
+begin
+  P('12345');
+  s:='12345';
+  p(s);
+  {Won't compile.
+  FPC or Turbo Pascal mode:  Internal error 200405241
+  Delphi mode:  Signal 291.  Save files and restart IDE.  (Can't save.)}
+end.
diff --git a/tests/webtbs/tw14941a.pp b/tests/webtbs/tw14941a.pp
new file mode 100644
index 0000000000..d053101fe3
--- /dev/null
+++ b/tests/webtbs/tw14941a.pp
@@ -0,0 +1,24 @@
+program StringTest5;
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+{$V+}
+var
+   s    :String;
+
+procedure P( s: OpenString);
+begin
+  writeln(s);
+  if (high(s)<>255) or
+     (s<>'12345') then
+    halt(1);
+end;
+
+begin
+  P('12345');
+  s:='12345';
+  p(s);
+  {Won't compile.
+  FPC or Turbo Pascal mode:  Internal error 200405241
+  Delphi mode:  Signal 291.  Save files and restart IDE.  (Can't save.)}
+end.