Merged revisions 7644-7645,7660-7662,7667,7670-7672 via svnmerge from

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

........
r7644 | jonas | 2007-06-13 14:59:39 +0200 (Wed, 13 Jun 2007) | 2 lines

  * force utf-8 for darwin

........
r7645 | jonas | 2007-06-13 15:00:25 +0200 (Wed, 13 Jun 2007) | 2 lines

  * fixed writing of widestrings

........
r7660 | jonas | 2007-06-14 12:56:29 +0200 (Thu, 14 Jun 2007) | 3 lines

  * also force utf-8 on Solaris, nl_langinfo(CODESET) doesn't work there
    either and utf-8 is also its default "international" encoding

........
r7661 | micha | 2007-06-14 16:45:19 +0200 (Thu, 14 Jun 2007) | 1 line

* fix cwstring compilation: remove extra "}"
........
r7662 | jonas | 2007-06-14 18:50:08 +0200 (Thu, 14 Jun 2007) | 3 lines

  * put tests in procedure so that an unbalanced stack will cause a crash
    when exiting it

........
r7667 | jonas | 2007-06-15 14:48:12 +0200 (Fri, 15 Jun 2007) | 5 lines

  * fixed calling cdecl routines under win32 which return their result in
    a structure whose address is passed by the caller (the caller is
    responsible there to remove the address from the stack, unlike on
    e.g. linux/i386 and darwin/i386)

........
r7670 | jonas | 2007-06-15 19:16:44 +0200 (Fri, 15 Jun 2007) | 4 lines

  * only allow automatic type conversions of array constructors of
    char to pchar/array of char, rather than of arbitrary array
    constructors (mantis #9085)

........
r7671 | jonas | 2007-06-15 19:36:09 +0200 (Fri, 15 Jun 2007) | 3 lines

  * also process all subnodes of try-except and try-finally in
    foreachnode(static) (fixes first example of mantis #9076)

........
r7672 | jonas | 2007-06-15 20:51:06 +0200 (Fri, 15 Jun 2007) | 5 lines

  * removed Darwin/Solaris-specific code and fixed all issues by calling
    setlocale(LC_ALL,'') per POSIX, which initialises the langinfo stuff
    based on the environment variables (some OS'es do that automatically,
    but at least Darwin and Solaris don't)

........

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

.gitattributes

@@ -6873,6 +6873,7 @@ tests/test/tvarset1.pp svneol=native#text/plain
 tests/test/tw6727.pp svneol=native#text/plain
 tests/test/twide1.pp svneol=native#text/plain
 tests/test/twide2.pp svneol=native#text/plain
+tests/test/twide3.pp svneol=native#text/plain
 tests/test/uabstrcl.pp svneol=native#text/plain
 tests/test/uenum2a.pp svneol=native#text/plain
 tests/test/uenum2b.pp svneol=native#text/plain
@@ -8136,6 +8137,9 @@ tests/webtbs/tw8870.pp svneol=native#text/plain
 tests/webtbs/tw8883.pp svneol=native#text/plain
 tests/webtbs/tw8919.pp svneol=native#text/plain
 tests/webtbs/tw9054.pp svneol=native#text/plain
+tests/webtbs/tw9076.pp svneol=native#text/plain
+tests/webtbs/tw9076a.pp svneol=native#text/plain
+tests/webtbs/tw9085.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

compiler/defcmp.pas

@@ -848,7 +848,11 @@ implementation
                    begin
                      { string constant (which can be part of array constructor)
                        to zero terminated string constant }
-                     if (fromtreetype in [arrayconstructorn,stringconstn]) and
+                     if (((fromtreetype = arrayconstructorn) and
+                          { can't use is_chararray, because returns false for }
+                          { array constructors                                }
+                          is_char(tarraydef(def_from).elementdef)) or
+                         (fromtreetype = stringconstn)) and
                         (is_pchar(def_to) or is_pwidechar(def_to)) then
                       begin
                         doconv:=tc_cstring_2_pchar;
@@ -937,7 +941,11 @@ implementation
                    begin
                      { string constant (which can be part of array constructor)
                        to zero terminated string constant }
-                     if (fromtreetype in [arrayconstructorn,stringconstn]) and
+                     if (((fromtreetype = arrayconstructorn) and
+                          { can't use is_chararray, because returns false for }
+                          { array constructors                                }
+                          is_char(tarraydef(def_from).elementdef)) or
+                         (fromtreetype = stringconstn)) and
                         (is_pchar(def_to) or is_pwidechar(def_to)) then
                       begin
                         doconv:=tc_cstring_2_pchar;

compiler/i386/n386cal.pas

@@ -81,6 +81,16 @@ implementation
             exit;
           end;
 
+        { on win32, the caller is responsible for removing the funcret     }
+        { pointer from the stack, unlike on Linux. Don't know about        }
+        { elsewhere (except Darwin, handled above), but since the default  }
+        { was "callee removes funcret pointer from stack" until now, we'll }
+        { keep that default for everyone else (ncgcal decreases popsize by }
+        { sizeof(aint) in case of ret_in_param())                          }
+        if (target_info.system = system_i386_win32) and
+            paramanager.ret_in_param(procdefinition.returndef,procdefinition.proccalloption) then
+           inc(pop_size,sizeof(aint));
+
         { better than an add on all processors }
         if pop_size=4 then
           begin

compiler/nutils.pas

@@ -126,7 +126,7 @@ implementation
             result := foreachnode(tcallnode(n).methodpointer,f,arg) or result;
             result := foreachnode(tcallnode(n).methodpointerdone,f,arg) or result;
           end;
-        ifn, whilerepeatn, forn:
+        ifn, whilerepeatn, forn, tryexceptn, tryfinallyn:
           begin
             { not in one statement, won't work because of b- }
             result := foreachnode(tloopnode(n).t1,f,arg) or result;
@@ -173,7 +173,7 @@ implementation
               result := foreachnodestatic(procmethod,tcallnode(n).methodpointer,f,arg) or result;
               result := foreachnodestatic(procmethod,tcallnode(n).methodpointerdone,f,arg) or result;
             end;
-          ifn, whilerepeatn, forn:
+          ifn, whilerepeatn, forn, tryexceptn, tryfinallyn:
             begin
               { not in one statement, won't work because of b- }
               result := foreachnodestatic(procmethod,tloopnode(n).t1,f,arg) or result;

rtl/inc/text.inc

@@ -623,6 +623,7 @@ Procedure fpc_Write_Text_WideStr (Len : Longint; Var f : Text; const S : WideStr
 }
 var
   SLen : longint;
+  a: ansistring;
 begin
   If (pointer(S)=nil) or (InOutRes<>0) then
    exit;
@@ -632,7 +633,9 @@ begin
         SLen:=Length(s);
         If Len>SLen Then
           fpc_WriteBlanks(f,Len-SLen);
-        fpc_WriteBuffer(f,PChar(AnsiString(S))^,SLen);
+        a:=s;
+        { length(a) can be > slen, e.g. after utf-16 -> utf-8 }
+        fpc_WriteBuffer(f,pchar(a)^,length(a));
       end;
     fmInput: InOutRes:=105
     else InOutRes:=103;

rtl/unix/cwstring.pp

@@ -58,27 +58,32 @@ function towlower(__wc:wint_t):wint_t;cdecl;external libiconvname name 'towlower
 function towupper(__wc:wint_t):wint_t;cdecl;external libiconvname name 'towupper';
 function wcscoll (__s1:pwchar_t; __s2:pwchar_t):cint;cdecl;external libiconvname name 'wcscoll';
 function strcoll (__s1:pchar; __s2:pchar):cint;cdecl;external libiconvname name 'strcoll';
+function setlocale(category: cint; locale: pchar): pchar; cdecl; external clib name 'setlocale';
 
 const
 {$ifdef linux}
   __LC_CTYPE = 0;
+  LC_ALL = 6;
   _NL_CTYPE_CLASS = (__LC_CTYPE shl 16);
   _NL_CTYPE_CODESET_NAME = (_NL_CTYPE_CLASS)+14;
   CODESET = _NL_CTYPE_CODESET_NAME;
 {$else linux}
 {$ifdef darwin}
   CODESET = 0;
+  LC_ALL = 0;
 {$else darwin}
 {$ifdef FreeBSD} // actually FreeBSD5. internationalisation is afaik not default on 4.
   __LC_CTYPE = 0;
+  LC_ALL = 0;
   _NL_CTYPE_CLASS = (__LC_CTYPE shl 16);
   _NL_CTYPE_CODESET_NAME = (_NL_CTYPE_CLASS)+14;
   CODESET = 0; // _NL_CTYPE_CODESET_NAME;
 {$else freebsd}
 {$ifdef solaris}
   CODESET=49;
+  LC_ALL = 6;
 {$else}
-{$error lookup the value of CODESET in /usr/include/langinfo.h for your OS }
+{$error lookup the value of CODESET in /usr/include/langinfo.h, and the value of LC_ALL in /usr/include/locale.h for your OS }
 // and while doing it, check if iconv is in libc, and if the symbols are prefixed with iconv_ or libiconv_
 {$endif solaris}
 {$endif FreeBSD}
@@ -372,6 +377,12 @@ end;
 initialization
   SetCWideStringManager;
   initcriticalsection(iconv_lock);
+
+  { you have to call setlocale(LC_ALL,'') to initialise the langinfo stuff  }
+  { with the information from the environment variables according to POSIX  }
+  { (some OSes do this automatically, but e.g. Darwin and Solaris don't)    }
+  setlocale(LC_ALL,'');
+
   { init conversion tables }
   iconv_wide2ansi:=iconv_open(nl_langinfo(CODESET),unicode_encoding);
   iconv_ansi2wide:=iconv_open(unicode_encoding,nl_langinfo(CODESET));

tests/test/cg/tcalext.pp

@@ -212,6 +212,8 @@ var
     value_long_double := 0.0;
   end;
 
+{ in sub procedure to detect stack corruption when exiting }
+procedure dotest;
 const
   has_errors : boolean = false;
 
@@ -788,4 +790,8 @@ begin
 
   if has_errors then
     Halt(1);
+end;
+
+begin
+  dotest;
 end.

tests/test/cg/tcalext2.pp

@@ -151,7 +151,6 @@ function test_function_struct : _7byte_; cdecl; external;
 
 
 
-
 var
  global_u8bit : byte; cvar; external;
  global_u16bit : word; cvar; external;
@@ -222,6 +221,7 @@ const
    end;
 
 
+procedure dotest;
 var failed : boolean;
     tinystruct : _1BYTE_;
     smallstruct : _3BYTE_;
@@ -259,4 +259,8 @@ begin
 
   if has_errors then
     Halt(1);
+end;
+
+begin
+  dotest;
 end.

tests/test/cg/tcalext3.pp

@@ -497,6 +497,7 @@ function pass_arr32(s : struct_arr32) : int64_t; cdecl; external;
 function pass_arr33(s : struct_arr33) : int64_t; cdecl; external;
 
 
+procedure dotest;
 var
   sa1 : struct_arr1;
   sa2 : struct_arr2;
@@ -614,4 +615,8 @@ begin
 
   if (not success) then
     halt(1);
+end;
+
+begin
+  dotest;
 end.

tests/test/cg/tcalext4.pp

@@ -75,6 +75,7 @@ function pass31(s : arr31) : int64; cdecl; external;
 function pass32(s : arr32) : int64; cdecl; external;
 function pass33(s : arr33) : int64; cdecl; external;
 
+procedure dotest;
 var
   s1 : arr1;
   s2 : arr2;
@@ -130,4 +131,8 @@ begin
 
   if (not success) then
     halt(1);
+end;
+
+begin
+  dotest;
 end.

tests/test/cg/tcalext5.pp

@@ -505,7 +505,7 @@ function pass_arr31(s : struct_arr31; b: byte) : int64_t; cdecl; external;
 function pass_arr32(s : struct_arr32; b: byte) : int64_t; cdecl; external;
 function pass_arr33(s : struct_arr33; b: byte) : int64_t; cdecl; external;
 
-
+procedure dotest;
 var
   sa1 : struct_arr1;
   sa2 : struct_arr2;
@@ -629,4 +629,8 @@ begin
 
   if (not success) then
     halt(1);
+end;
+
+begin
+  dotest;
 end.

tests/test/twide3.pp

@@ -0,0 +1,32 @@
+{$codepage utf-8}
+
+{$mode objfpc}
+uses
+{$ifdef unix}
+  cwstring,
+{$endif}
+  sysutils;
+
+{$i+}
+
+var
+  t: text;
+  w: widestring;
+  a: ansistring;
+
+begin
+  assign(t,'twide3.txt');
+  rewrite(t);
+  writeln(t,'łóżka');
+  close(t);
+  reset(t);
+  try
+    readln(t,a);
+    w:=a;
+    if (w<>'łóżka') then
+      raise Exception.create('wrong string read');
+  finally
+    close(t);
+    erase(t);
+  end;
+end.

tests/webtbs/tw9076.pp

@@ -0,0 +1,29 @@
+{ %norun }
+
+unit tw9076;
+
+{$mode objfpc}
+
+interface
+
+type
+  pfdset = pointer;
+
+function __Select(N: Longint; ReadFds: PFDSet; WriteFds: PFDSet;
+ExceptFds: PFDSet): Longint; inline;
+
+implementation
+
+function __Select(N: Longint; ReadFds: PFDSet; WriteFds: PFDSet;
+ExceptFds: PFDSet): Longint;
+begin
+  try
+    result := 2
+  except
+    Result := -1
+  end
+end;
+
+end.
+
+

tests/webtbs/tw9076a.pp

@@ -0,0 +1,10 @@
+{ %norun }
+
+program chatserver;
+
+uses tw9076;
+
+begin
+  __Select(0, nil, nil, nil)
+end.
+

tests/webtbs/tw9085.pp

@@ -0,0 +1,25 @@
+program chatserver;
+
+{$mode objfpc}
+
+procedure Sendln(MsgType: Longint; Str: PChar);
+begin
+  halt(1);
+end;
+
+procedure Sendln(MsgType: Longint; Str: array of PChar);
+begin
+  halt(0);
+end;
+
+
+procedure Sendln(MsgType: Longint; Str: array of char);
+begin
+  halt(1);
+end;
+
+
+
+begin
+  Sendln(1, ['str1', 'str2'])
+end.