Merged revisions 6855,6864-6866,6868-6869,6872,6882-6883,6889,6891,6893-6894,6896,6898,6901-6903,6908,6916,6921-6922,6924-6925,6927-6928,6930,6943-6946,6952,6954,6956,6974,6976,6996-6997,7002,7007,7016,7020-7021,7033,7037,7040,7042,7045,7068-7069,7075-7079,7087,7094,7098-7099,7101,7103,7109,7115-7119,7128,7136-7137,7139,7150,7160-7162,7175,7179,7190-7195,7198,7202,7205-7206,7208-7217,7220-7222,7225-7228,7230,7233,7239-7241,7244,7246,7254,7256,7263,7275,7277,7279-7281,7285,7288-7289,7291-7293,7296,7300,7303,7310,7318,7337,7340-7341,7343-7346,7372-7373,7375-7376,7379,7381,7383-7388,7391-7392,7400,7404-7406,7411,7422,7425,7436,7441-7442,7444-7445,7450,7456,7463,7467,7475,7479,7486,7504,7506-7509,7517,7522,7527,7534-7536,7558-7559,7563-7565,7567,7570-7571,7573-7576,7586,7589,7592-7594,7607,7612,7615,7619-7620,7622-7623,7626,7628,7631,7633,7646,7658,7663,7677,7681-7683,7689,7697,7704-7712,7725,7736,7738,7740,7744-7746,7751,7753,7764,7767,7769-7770,7776-7777,7788,7830,7836-7839,7846,7849,7862,7864-7865,7869,7872,7877,7882,7902,7927-7929,7937-7938,7940,7953,7961,7967,7971,7986-7987,7990-7994,7998-8000,8004-8006,8008-8012,8016,8027,8034,8036-8037,8039,8044,8046,8048,8051,8060,8071,8075-8076,8082-8083,8087-8089,8095-8096,8099-8100,8136,8187,8190,8203,8206-8207,8212-8213,8215,8225,8227,8233-8239,8245,8262,8274 via svnmerge from

http://svn.freepascal.org/svn/fpc/trunk

........
  r6855 | jonas | 2007-03-14 20:45:07 +0100 (Wed, 14 Mar 2007) | 7 lines
  
    * changed fpc_big_chararray and fpc_big_widechararray from
      array[0..1023] into array[0..0], because they're used as
      dummy return types for the Xstring_to_chararray helpers,
      and if a smaller array is actually passed as result then
      having a larger array declared will cause -gt to
      overwrite other data
........
  r7254 | daniel | 2007-05-04 00:54:12 +0200 (Fri, 04 May 2007) | 2 lines
  
   - Comment out duplicate entries (F11/F12 <--> Shift+F1/F2)
........
  r7256 | jonas | 2007-05-04 10:26:38 +0200 (Fri, 04 May 2007) | 2 lines
  
    * fixed compilation
........
  r7337 | micha | 2007-05-14 23:09:16 +0200 (Mon, 14 May 2007) | 1 line
  
  * fix heap mutex deadlock in case of runtime error within heap management (needs recursive heap mutex)
........
  r7344 | pierre | 2007-05-15 15:37:19 +0200 (Tue, 15 May 2007) | 1 line
  
   + code to debug LFN FindFirst/findClose
........
  r7346 | pierre | 2007-05-15 15:41:26 +0200 (Tue, 15 May 2007) | 1 line
  
   + new program to ease cross RTL compilation tests
........
  r7517 | yury | 2007-05-29 19:03:03 +0200 (Tue, 29 May 2007) | 1 line
  
  * fixed compilation for wince.
........
  r7658 | jonas | 2007-06-14 09:25:47 +0200 (Thu, 14 Jun 2007) | 2 lines
  
    * added {$inline on} directive to fix compilation with 2.0.4
........
  r7902 | daniel | 2007-07-01 13:42:34 +0200 (Sun, 01 Jul 2007) | 2 lines
  
    * Pointer to integer conversion not necessary here.
........
  r7937 | hajny | 2007-07-03 23:00:01 +0200 (Tue, 03 Jul 2007) | 1 line
  
    * give up timeslices while waiting in SysGetMouseEvent, compilation fix plus change of pointer conversion to unsigned
........
  r7938 | daniel | 2007-07-03 23:28:59 +0200 (Tue, 03 Jul 2007) | 2 lines
  
    * Prevent range check error at compile time.
........
  r7940 | daniel | 2007-07-03 23:40:54 +0200 (Tue, 03 Jul 2007) | 3 lines
  
    * Convert to code that also works correct in $T+ case.
    * Remove typecasts to longint.
........
  r8245 | jonas | 2007-08-08 13:33:54 +0200 (Wed, 08 Aug 2007) | 2 lines
  
    * cache result of GetThreadManager in InitThreads
........
  r8274 | jonas | 2007-08-12 22:01:08 +0200 (Sun, 12 Aug 2007) | 14 lines
  
    + support for widestring manager based widechar conversions
      (widechar<->char, widechar<>*string), based on patch from
      Rimgaudas Laucius (mantis #7758)
    * no longer perform compile-time widechar/string->char/ansi/
      shortstring conversions if they would destroy information
      (they can't cope with widechars with ord>=128). This means
      that you can now properly constant widechars/widestrings
      in source code with a {$codepage } set without risking that
      the compiler will mangle everything afterwards
    * support ESysEINVAL return code from iconv (happens if last
      multibyte char is incomplete)
    * fixed writing of widechars (were converted to char -> lost
      information)
........

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

.gitattributes

@@ -497,6 +497,7 @@ compiler/tokens.pas svneol=native#text/plain
 compiler/utils/Makefile svneol=native#text/plain
 compiler/utils/Makefile.fpc svneol=native#text/plain
 compiler/utils/README -text
+compiler/utils/dummyas.pp -text
 compiler/utils/fixlog.pp svneol=native#text/plain
 compiler/utils/fixmsg.pp svneol=native#text/plain
 compiler/utils/fixnasm.pp svneol=native#text/plain
@@ -8261,6 +8262,8 @@ tests/webtbs/tw7679.pp svneol=native#text/plain
 tests/webtbs/tw7719.pp svneol=native#text/plain
 tests/webtbs/tw7733.pp svneol=native#text/plain
 tests/webtbs/tw7756.pp svneol=native#text/plain
+tests/webtbs/tw7758.pp svneol=native#text/plain
+tests/webtbs/tw7758a.pp svneol=native#text/plain
 tests/webtbs/tw7803.pp svneol=native#text/plain
 tests/webtbs/tw7806.pp svneol=native#text/plain
 tests/webtbs/tw7808.pp svneol=native#text/plain

compiler/ncgcnv.pas

@@ -514,9 +514,7 @@ interface
 
     procedure tcgtypeconvnode.second_char_to_char;
       begin
-        {$warning todo: add RTL routine for widechar-char conversion }
-        { Quick hack to at least generate 'working' code (PFV) }
-        second_int_to_int;
+        internalerror(2007081202);
       end;
 
 

compiler/ncnv.pas

@@ -893,8 +893,7 @@ implementation
       begin
          result:=nil;
          if (left.nodetype=stringconstn) and
-            ((not is_widechararray(left.resultdef) and
-              not is_widestring(left.resultdef)) or
+            ((tstringdef(left.resultdef).stringtype<>st_widestring) or
              (tstringdef(resultdef).stringtype=st_widestring) or
              { non-ascii chars would be replaced with '?' -> loses info }
              not hasnonasciichars(pcompilerwidestring(tstringconstnode(left).value_str))) then
@@ -902,7 +901,7 @@ implementation
              tstringconstnode(left).changestringtype(resultdef);
              result:=left;
              left:=nil;
-          end
+           end
          else
            begin
              { get the correct procedure name }
@@ -935,7 +934,13 @@ implementation
 
       begin
          result:=nil;
-         if left.nodetype=ordconstn then
+         { we can't do widechar to ansichar conversions at compile time, since }
+         { this maps all non-ascii chars to '?' -> loses information           }
+         if (left.nodetype=ordconstn) and
+            ((tstringdef(resultdef).stringtype=st_widestring) or
+             (torddef(left.resultdef).ordtype=uchar) or
+             { >=128 is destroyed }
+             (tordconstnode(left).value<128)) then
            begin
               if tstringdef(resultdef).stringtype=st_widestring then
                begin
@@ -949,22 +954,30 @@ implementation
                end
               else
                 begin
-                  hp:=cstringconstnode.createstr(chr(tordconstnode(left).value));
+                  if torddef(left.resultdef).ordtype=uwidechar then
+                    hp:=cstringconstnode.createstr(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value)))
+                  else
+                    hp:=cstringconstnode.createstr(chr(tordconstnode(left).value));
                   tstringconstnode(hp).changestringtype(resultdef);
                 end;
               result:=hp;
            end
          else
-           { shortstrings are handled 'inline' }
-           if tstringdef(resultdef).stringtype <> st_shortstring then
+           { shortstrings are handled 'inline' (except for widechars) }
+           if (tstringdef(resultdef).stringtype <> st_shortstring) or
+              (torddef(left.resultdef).ordtype = uwidechar) then
              begin
-               { create the parameter }
+               { create the procname }
+               if torddef(left.resultdef).ordtype<>uwidechar then
+                 procname := 'fpc_char_to_'
+               else
+                 procname := 'fpc_wchar_to_';
+               procname:=procname+tstringdef(resultdef).stringtypname;
+
+               { and the parameter }
                para := ccallparanode.create(left,nil);
                left := nil;
 
-               { and the procname }
-               procname := 'fpc_char_to_' +tstringdef(resultdef).stringtypname;
-
                { and finally the call }
                result := ccallnode.createinternres(procname,para,resultdef);
              end
@@ -1009,7 +1022,11 @@ implementation
 
       begin
          result:=nil;
-         if left.nodetype=ordconstn then
+         if (left.nodetype=ordconstn) and
+            ((torddef(resultdef).ordtype<>uchar) or
+             (torddef(left.resultdef).ordtype<>uwidechar) or
+             { >= 128 is replaced by '?' currently -> loses information }
+             (tordconstnode(left).value<128)) then
            begin
              if (torddef(resultdef).ordtype=uchar) and
                 (torddef(left.resultdef).ordtype=uwidechar) then
@@ -2291,9 +2308,21 @@ implementation
 
 
     function ttypeconvnode.first_char_to_char : tnode;
+      var
+        fname: string[18];
+      begin
+        if (torddef(resultdef).ordtype=uchar) and
+           (torddef(left.resultdef).ordtype=uwidechar) then
+          fname := 'fpc_wchar_to_char'
+        else if (torddef(resultdef).ordtype=uwidechar) and
+           (torddef(left.resultdef).ordtype=uchar) then
+          fname := 'fpc_char_to_wchar'
+        else
+          internalerror(2007081201);
 
-      begin
-         first_char_to_char:=first_int_to_int;
+        result := ccallnode.createintern(fname,ccallparanode.create(left,nil));
+        left:=nil;
+        firstpass(result);
       end;
 
 

compiler/utils/dummyas.pp

@@ -0,0 +1,111 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2007 by Pierre Muller
+    member of the Free Pascal development team.
+
+    Dummy assembler program to be able to easily test
+    all FPC targets even without cross tools.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+program dummyas;
+
+var
+  assembler_name : string;
+  object_name : string;
+  ofile : text;
+
+function RemoveSuffix(const st : string) : string;
+var
+  i,last : longint;
+begin
+  last:=length(st);
+  for i:=length(st) downto 1 do
+    begin
+      if st[i]='.' then
+        begin
+          last:=i-1;
+          break;
+        end;
+    end;
+  RemoveSuffix:=Copy(st,1,last);
+end;
+
+var
+  i : longint;
+  param : string;
+  skipnext : boolean;
+begin
+  object_name:='';
+  skipnext:=false;
+  for i:=1 to ParamCount do
+    begin
+      param:=Paramstr(i);
+      if skipnext or (length(Param)=0) then
+        begin
+          skipnext:=false;
+          continue;
+        end;
+      if Param='-o' then
+        begin
+          skipnext:=true;
+          object_name:=ParamStr(i+1);
+        end
+      else if (Param[1]='-') then
+        begin
+          { option Param not handled }
+          { Shouldn't be a real problem }
+        end
+      else
+        begin
+          if assembler_name='' then
+            assembler_name:=ParamStr(i)
+          else
+            begin
+              Writeln(stderr,'two non option param found!');
+              Writeln(stderr,'first non option param =',assembler_name);
+              Writeln(stderr,'second non option param =',Param);
+              Writeln(stderr,'Don''t know how to handle this!');
+              halt(1);
+            end;
+        end;
+    end;
+
+  if assembler_name='' then
+    begin
+      Writeln(stderr,'Dummyas, no source file specified');
+      halt(1);
+    end;
+  Assign(ofile,assembler_name);
+{$I-}
+  Reset(ofile);
+  if IOResult<>0 then
+    begin
+      Writeln(stderr,'Dummyas, source file not found ',assembler_name);
+      halt(1);
+    end;
+  Close(ofile);
+  if object_name='' then
+    object_name:=RemoveSuffix(assembler_name)+'.o';
+  Assign(ofile,object_name);
+  Rewrite(ofile);
+  if IOResult<>0 then
+    begin
+      Writeln(stderr,'Dummyas, object file not writable ',object_name);
+      halt(1);
+    end;
+  Writeln(ofile,'Dummy as called');
+  for i:=0 to Paramcount do
+    Write(ofile,ParamStr(i),' ');
+  Writeln(ofile);
+  Writeln(ofile,'assembler file=',assembler_name);
+  Writeln(ofile,'object file=',object_name);
+  Close(ofile);
+end.

rtl/go32v2/dos.pp

@@ -446,6 +446,14 @@ begin
    end;
 end;
 
+{$ifdef DEBUG_LFN}
+const
+  LFNFileName : string = 'LFN.log';
+  LFNOpenNb : longint = 0;
+  LogLFN : boolean = false;
+var
+  lfnfile : text;
+{$endif DEBUG_LFN}
 
 procedure LFNFindFirst(path:pchar;attr:longint;var s:searchrec);
 var
@@ -469,6 +477,15 @@ begin
   dosregs.ax:=$714e;
   msdos(dosregs);
   LoadDosError;
+{$ifdef DEBUG_LFN}
+  if (DosError=0) and LogLFN then
+    begin
+      Append(lfnfile);
+      inc(LFNOpenNb);
+      Writeln(lfnfile,LFNOpenNb,' LFNFindFirst called ',path);
+      close(lfnfile);
+    end;
+{$endif DEBUG_LFN}
   copyfromdos(w,sizeof(LFNSearchRec));
   LFNSearchRec2Dos(w,dosregs.ax,s,true);
 end;
@@ -507,6 +524,16 @@ begin
   dosregs.ax:=$71a1;
   msdos(dosregs);
   LoadDosError;
+{$ifdef DEBUG_LFN}
+  if (DosError=0) and LogLFN  then
+    begin
+      Append(lfnfile);
+      Writeln(lfnfile,LFNOpenNb,' LFNFindClose called ');
+      close(lfnfile);
+      if LFNOpenNb>0 then
+        dec(LFNOpenNb);
+    end;
+{$endif DEBUG_LFN}
 end;
 
 
@@ -839,5 +866,18 @@ begin
    end;
 end;
 
+{$ifdef DEBUG_LFN}
+begin
+  LogLFN:=(GetEnv('LOGLFN')<>'');
+  assign(lfnfile,LFNFileName);
+{$I-}
+  Reset(lfnfile);
+  if IOResult<>0 then
+    begin
+      Rewrite(lfnfile);
+      Writeln(lfnfile,'New lfn.log');
+    end;
+  close(lfnfile);
+{$endif DEBUG_LFN}
 
 end.

rtl/go32v2/mouse.pp

@@ -740,6 +740,8 @@ const
   LastCallcounter : longint = 0;
 
 procedure SysGetMouseEvent(var MouseEvent: TMouseEvent);
+var
+ RR: TRealRegs;
 begin
   if not MousePresent then
     begin
@@ -754,11 +756,15 @@ begin
 {$endif EXTMOUSEDEBUG}
   LastCallcounter:=Callcounter;
 {$endif DEBUG}
-  repeat until PendingMouseEvents>0;
+  while PendingMouseEvents = 0 do
+   begin
+(* Give up time slices while waiting for mouse events. *)
+    RealIntr ($28, RR);
+   end;
   MouseEvent:=PendingMouseHead^;
   inc(PendingMouseHead);
-  if longint(PendingMouseHead)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
-   PendingMouseHead:=@PendingMouseEvent;
+  if PendingMouseHead=@PendingMouseEvent[0]+MouseEventBufsize then
+   PendingMouseHead:=@PendingMouseEvent[0];
   dec(PendingMouseEvents);
   if (LastMouseEvent.x<>MouseEvent.x) or (LastMouseEvent.y<>MouseEvent.y) then
    MouseEvent.Action:=MouseActionMove;

rtl/inc/compproc.inc

@@ -184,6 +184,7 @@ Procedure fpc_AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString)
 function fpc_AnsiStr_To_ShortStr (high_of_res: SizeInt;const S2 : Ansistring): shortstring; compilerproc;
 Function fpc_ShortStr_To_AnsiStr (Const S2 : ShortString): ansistring; compilerproc;
 Function fpc_Char_To_AnsiStr(const c : Char): AnsiString; compilerproc;
+
 Function fpc_PChar_To_AnsiStr(const p : pchar): ansistring; compilerproc;
 Function fpc_CharArray_To_AnsiStr(const arr: array of char; zerobased: boolean = true): ansistring; compilerproc;
 {$ifndef FPC_STRTOCHARARRAYPROC}
@@ -221,7 +222,7 @@ function fpc_WideStr_Concat_multi (const sarr:array of Widestring): widestring;
 Procedure fpc_WideStr_Concat (Var DestS : Widestring;const S1,S2 : WideString); compilerproc;
 Procedure fpc_WideStr_Concat_multi (Var DestS : Widestring;const sarr:array of Widestring); compilerproc;
 {$endif STR_CONCAT_PROCS}
-Function fpc_Char_To_WideStr(const c : WideChar): WideString; compilerproc;
+Function fpc_Char_To_WideStr(const c : Char): WideString; compilerproc;
 Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
 Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;
 {$ifndef FPC_STRTOCHARARRAYPROC}
@@ -247,6 +248,11 @@ Function  fpc_widestr_Copy (Const S : WideString; Index,Size : SizeInt) : WideSt
 {$ifndef FPC_WINLIKEWIDESTRING}
 function fpc_widestr_Unique(Var S : Pointer): Pointer; compilerproc;
 {$endif FPC_WINLIKEWIDESTRING}
+Function fpc_Char_To_WChar(const c : Char): WideChar; compilerproc;
+Function fpc_WChar_To_Char(const c : WideChar): Char; compilerproc;
+Function fpc_WChar_To_ShortStr(const c : WideChar): ShortString; compilerproc;
+Function fpc_WChar_To_AnsiStr(const c : WideChar): AnsiString; compilerproc;
+Function fpc_WChar_To_WideStr(const c : WideChar): WideString; compilerproc;
 {$endif FPC_HAS_FEATURE_WIDESTRINGS}
 
 {$ifdef FPC_HAS_FEATURE_WIDESTRINGS}

rtl/inc/heaptrc.pp

@@ -15,6 +15,8 @@
 unit heaptrc;
 interface
 
+{$inline on}
+
 {$ifdef FPC_HEAPTRC_EXTRA}
   {$define EXTRA}
 {$endif FPC_HEAPTRC_EXTRA}

rtl/inc/mouse.inc

@@ -11,6 +11,8 @@
 
  **********************************************************************}
 
+{$T+}
+
 Var
   CurrentMouseDriver : TMouseDriver;
   MouseInitialized : Boolean;
@@ -118,7 +120,7 @@ Procedure GetPendingEvent(Var MouseEvent:TMouseEvent);
 begin
   MouseEvent:=PendingMouseHead^;
   inc(PendingMouseHead);
-  if PtrInt(PendingMouseHead)=Ptrint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+  if PendingMouseHead=@PendingMouseEvent[0]+MouseEventBufSize then
    PendingMouseHead:=@PendingMouseEvent[0];
   dec(PendingMouseEvents);
   if (LastMouseEvent.x<>MouseEvent.x) or
@@ -161,7 +163,7 @@ begin
     begin
     PendingMouseTail^:=MouseEvent;
     inc(PendingMouseTail);
-    if PtrInt(PendingMouseTail)=Ptrint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+    if PendingMouseTail=@PendingMouseEvent[0]+MouseEventBufSize then
       PendingMouseTail:=@PendingMouseEvent[0];
     inc(PendingMouseEvents);
     end

rtl/inc/text.inc

@@ -746,7 +746,7 @@ End;
 
 Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); iocheck; [Public,Alias:'FPC_WRITE_TEXT_WIDECHAR']; compilerproc;
 var
-  ch : char;
+  a : ansistring;
 Begin
   If (InOutRes<>0) then
     exit;
@@ -762,9 +762,9 @@ Begin
     fpc_WriteBlanks(t,Len-1);
   If TextRec(t).BufPos>=TextRec(t).BufSize Then
     FileFunc(TextRec(t).InOutFunc)(TextRec(t));
-  ch:=c;
-  TextRec(t).Bufptr^[TextRec(t).BufPos]:=ch;
-  Inc(TextRec(t).BufPos);
+  { a widechar can be translated into more than a single ansichar }
+  a:=c;
+  fpc_WriteBuffer(t,pchar(a)^,length(a));
 End;
 
 

rtl/inc/wstrings.inc

@@ -592,15 +592,21 @@ end;
 
 {$endif STR_CONCAT_PROCS}
 
+Function fpc_Char_To_WChar(const c : Char): WideChar; compilerproc;
+var
+  w: widestring;
+begin
+  widestringmanager.Ansi2WideMoveProc(@c, w, 1);
+  fpc_Char_To_WChar:= w[1];    
+end;  
+ 
 
-Function fpc_Char_To_WideStr(const c : WideChar): WideString; compilerproc;
+
+Function fpc_Char_To_WideStr(const c : Char): WideString; compilerproc;
 {
   Converts a Char to a WideString;
 }
 begin
-  if c = #0 then
-    { result is automatically set to '' }
-    exit;
   Setlength(fpc_Char_To_WideStr,1);
   fpc_Char_To_WideStr[1]:=c;
   { Terminating Zero }
@@ -608,6 +614,52 @@ begin
 end;
 
 
+Function fpc_WChar_To_Char(const c : WideChar): Char; compilerproc;
+{
+  Converts a WideChar to a Char;
+}
+var
+  s: ansistring;
+begin
+  widestringmanager.Wide2AnsiMoveProc(@c, s, 1);
+  if length(s)=1 then
+    fpc_WChar_To_Char:= s[1]
+  else
+    fpc_WChar_To_Char:='?';
+end;
+
+
+Function fpc_WChar_To_WideStr(const c : WideChar): WideString; compilerproc;
+{
+  Converts a WideChar to a WideString;
+}
+begin
+  Setlength (fpc_WChar_To_WideStr,1);
+  fpc_WChar_To_WideStr[1]:= c;
+end;
+
+
+Function fpc_WChar_To_AnsiStr(const c : WideChar): AnsiString; compilerproc;
+{
+  Converts a WideChar to a AnsiString;
+}
+begin
+  widestringmanager.Wide2AnsiMoveProc(@c, fpc_WChar_To_AnsiStr, 1);
+end;
+
+
+Function fpc_WChar_To_ShortStr(const c : WideChar): ShortString; compilerproc;
+{
+  Converts a WideChar to a ShortString;
+}
+var
+  s: ansistring;
+begin
+  widestringmanager.Wide2AnsiMoveProc(@c, s, 1);
+  fpc_WChar_To_ShortStr:= s;
+end;
+
+
 Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
 Var
   L : SizeInt;

rtl/os2/mouse.pp

@@ -275,7 +275,7 @@ begin
    WF := Mou_NoWait;
    if (MouReadEventQue (SysEvent, WF, Handle) = 0) then
    begin
-    if PendingMouseHead = @PendingMouseEvent then
+    if PendingMouseHead = @PendingMouseEvent[0] then
                            P := @PendingMouseEvent [MouseEventBufSize - 1] else
     begin
      P := PendingMouseHead;
@@ -297,7 +297,7 @@ begin
        TranslateEvents (SysEvent, Event);
        if Event.Action <> MouseActionMove then
        begin
-        if Q = @PendingMouseEvent then
+        if Q = @PendingMouseEvent[0] then
                   Q := @PendingMouseEvent [MouseEventBufSize - 1] else Dec (Q);
         if MouseEventOrderHead = 0 then
                   MouseEventOrderHead := MouseEventBufSize - 1 else
@@ -359,8 +359,8 @@ begin
   LastMouseEvent := MouseEvent;
  end;
  Inc (PendingMouseHead);
- if longint (PendingMouseHead) = longint (@PendingMouseEvent)
-      + SizeOf (PendingMouseEvent) then PendingMouseHead := @PendingMouseEvent;
+ if PendingMouseHead = @PendingMouseEvent[0]+MouseEventBufsize then
+   PendingMouseHead := @PendingMouseEvent[0];
  Inc (MouseEventOrderHead);
  if MouseEventOrderHead = MouseEventBufSize then MouseEventOrderHead := 0;
  Dec (PendingMouseEvents);
@@ -374,8 +374,8 @@ begin
  begin
   PendingMouseTail^ := MouseEvent;
   Inc (PendingMouseTail);
-  if longint (PendingMouseTail) = longint (@PendingMouseEvent) +
-        SizeOf (PendingMouseEvent) then PendingMouseTail := @PendingMouseEvent;
+  if PendingMouseTail=@PendingMouseEvent[0]+MouseEventBufSize then
+    PendingMouseTail := @PendingMouseEvent[0];
   MouGetNumQueEl (QI, Handle);
   PendingMouseEventOrder [MouseEventOrderTail] := QI.cEvents;
   Inc (MouseEventOrderTail);

rtl/unix/cthreads.pp

@@ -603,22 +603,22 @@ end;
 
     procedure PThreadHeapMutexInit;
       begin
-         pthread_mutex_init(@heapmutex,nil);
+         CInitCriticalSection(heapmutex);
       end;
 
     procedure PThreadHeapMutexDone;
       begin
-         pthread_mutex_destroy(@heapmutex);
+         CDoneCriticalSection(heapmutex);
       end;
 
     procedure PThreadHeapMutexLock;
       begin
-         pthread_mutex_lock(@heapmutex);
+         CEnterCriticalSection(heapmutex);
       end;
 
     procedure PThreadHeapMutexUnlock;
       begin
-         pthread_mutex_unlock(@heapmutex);
+         CLeaveCriticalSection(heapmutex);
       end;
 
     const

rtl/unix/cwstring.pp

@@ -139,6 +139,7 @@ procedure Wide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
     destpos: pchar;
     mynil : pchar;
     my0 : size_t;
+    err: cint;
   begin
     mynil:=nil;
     my0:=0;
@@ -151,7 +152,11 @@ procedure Wide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
     outleft:=outlength;
     while iconv(iconv_wide2ansi,ppchar(@srcpos),@srclen,@destpos,@outleft)=size_t(-1) do
       begin
-        case fpgetCerrno of
+        err:=fpgetCerrno;
+        case err of
+          { last character is incomplete sequence }
+          ESysEINVAL,
+          { incomplete sequence in the middle }
           ESysEILSEQ:
             begin
               { skip and set to '?' }
@@ -162,6 +167,8 @@ procedure Wide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
               dec(outleft);
               { reset }
               iconv(iconv_wide2ansi,@mynil,@my0,@mynil,@my0);
+              if err=ESysEINVAL then
+                break;
             end;
           ESysE2BIG:
             begin
@@ -191,19 +198,21 @@ procedure Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
     destpos: pchar;
     mynil : pchar;
     my0 : size_t;
+    err: cint;
   begin
     mynil:=nil;
     my0:=0;
     // extra space
     outlength:=len+1;
     setlength(dest,outlength);
-    outlength:=len+1;
     srcpos:=source;
     destpos:=pchar(dest);
     outleft:=outlength*2;
     while iconv(iconv_ansi2wide,@srcpos,psize(@len),@destpos,@outleft)=size_t(-1) do
       begin
-        case fpgetCerrno of
+        err:=fpgetCerrno;
+        case err of
+         ESysEINVAL,
          ESysEILSEQ:
             begin
               { skip and set to '?' }
@@ -214,6 +223,8 @@ procedure Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
               dec(outleft,2);
               { reset }
               iconv(iconv_ansi2wide,@mynil,@my0,@mynil,@my0);
+              if err=ESysEINVAL then
+                break;
             end;
           ESysE2BIG:
             begin

rtl/unix/keyboard.pp

@@ -739,7 +739,7 @@ type  key_sequence=packed record
         st:string[7];
       end;
 
-const key_sequences:array[0..278] of key_sequence=(
+const key_sequences:array[0..276] of key_sequence=(
        (char:0;scan:kbAltA;st:#27'A'),
        (char:0;scan:kbAltA;st:#27'a'),
        (char:0;scan:kbAltB;st:#27'B'),
@@ -870,8 +870,10 @@ const key_sequences:array[0..278] of key_sequence=(
        (char:0;scan:kbDown;st:#27'OB'),          {xterm}
        (char:0;scan:kbRight;st:#27'OC'),         {xterm}
        (char:0;scan:kbLeft;st:#27'OD'),          {xterm}
+(* Already recognized above as F11!
        (char:0;scan:kbShiftF1;st:#27'[23~'),     {rxvt}
        (char:0;scan:kbShiftF2;st:#27'[24~'),     {rxvt}
+*)
        (char:0;scan:kbShiftF3;st:#27'[25~'),     {linux,rxvt}
        (char:0;scan:kbShiftF4;st:#27'[26~'),     {linux,rxvt}
        (char:0;scan:kbShiftF5;st:#27'[28~'),     {linux,rxvt}

rtl/unix/tthread.inc

@@ -62,7 +62,19 @@ begin
   { operation having been finished by another thread already, it will  }
   { use an uninitialised thread manager -> leave as it is              }
   if not ThreadsInited then
-    GetThreadManager(CurrentTM);
+    begin
+      GetThreadManager(CurrentTM);
+{$ifdef FPC_HAS_MEMBAR}
+      { however, we have to ensure that a thread never sees ThreadsInited }
+      { as true while CurrentTM hasn't been initialised yet               }
+      WriteBarrier;
+      ThreadsInited := True;
+{$endif}
+    end
+  else
+    { See double checked lock example at                         }
+    { http://ridiculousfish.com/blog/archives/2007/02/17/barrier }
+    ReadDependencyBarrier;
 end;
 
 procedure DoneThreads;

rtl/win32/system.pp

@@ -927,9 +927,11 @@ procedure Win32Wide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
     destlen: SizeInt;
   begin
     // retrieve length including trailing #0
-    destlen:=WideCharToMultiByte(CP_ACP, 0, source, len+1, nil, 0, nil, nil);
-    setlength(dest, destlen-1);
-    WideCharToMultiByte(CP_ACP, 0, source, len+1, @dest[1], destlen, nil, nil);
+    // not anymore, because this must also be usable for single characters
+    destlen:=WideCharToMultiByte(CP_ACP, 0, source, len, nil, 0, nil, nil);
+    // this will null-terminate
+    setlength(dest, destlen);
+    WideCharToMultiByte(CP_ACP, 0, source, len, @dest[1], destlen, nil, nil);
   end;
 
 procedure Win32Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
@@ -937,9 +939,11 @@ procedure Win32Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
     destlen: SizeInt;
   begin
     // retrieve length including trailing #0
-    destlen:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len+1, nil, 0);
-    setlength(dest, destlen-1);
-    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len+1, @dest[1], destlen);
+    // not anymore, because this must also be usable for single characters
+    destlen:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, nil, 0);
+    // this will null-terminate
+    setlength(dest, destlen);
+    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, @dest[1], destlen);
   end;
 
 

rtl/win64/system.pp

@@ -969,9 +969,11 @@ procedure Win32Wide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
     destlen: SizeInt;
   begin
     // retrieve length including trailing #0
-    destlen:=WideCharToMultiByte(CP_ACP, 0, source, len+1, nil, 0, nil, nil);
-    setlength(dest, destlen-1);
-    WideCharToMultiByte(CP_ACP, 0, source, len+1, @dest[1], destlen, nil, nil);
+    // not anymore, because this must also be usable for single characters
+    destlen:=WideCharToMultiByte(CP_ACP, 0, source, len, nil, 0, nil, nil);
+    // this will null-terminate
+    setlength(dest, destlen);
+    WideCharToMultiByte(CP_ACP, 0, source, len, @dest[1], destlen, nil, nil);
   end;
 
 procedure Win32Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
@@ -979,9 +981,11 @@ procedure Win32Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
     destlen: SizeInt;
   begin
     // retrieve length including trailing #0
-    destlen:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len+1, nil, 0);
-    setlength(dest, destlen-1);
-    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len+1, @dest[1], destlen);
+    // not anymore, because this must also be usable for single characters
+    destlen:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, nil, 0);
+    // this will null-terminate
+    setlength(dest, destlen);
+    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, @dest[1], destlen);
   end;
 
 

tests/webtbs/tw7758.pp

@@ -0,0 +1,148 @@
+{$codepage utf8}
+
+uses
+{$ifdef unix}
+  cwstring,
+{$endif}
+  sysutils;
+
+const
+  cwc=widechar('a');
+  c2=widechar('é');
+  c3=widestring('é');
+var
+  c: char;
+  wc,wc2: widechar;
+  s,s2,a: ansistring;
+  w: widestring;
+  ss: shortstring;
+begin
+  c:=#0;
+  w:=c;
+  if (length(w)<>1) or
+     (w[1]<>#0) then
+    halt(1);
+  s:='é';
+  w:=s;
+  wc:=w[1];
+  s2:=wc;
+  if (w <> s2) or
+     (s <> s2) then
+    halt(2);
+
+  c:=#0;
+  wc:=c;
+  c:=wc;
+  if (c<>#0) or
+     (wc<>#0) then
+    halt(5);
+  ss:=wc;
+  wc:=ss[1];
+  if (length(ss)<>1) or
+     (ss[1]<>#0) or
+     (wc<>#0) then
+    halt(6);
+  a:=wc;
+  wc:=a[1];
+  if (length(a)<>1) or
+     (a[1]<>#0) or
+     (wc<>#0) then
+    halt(7);
+
+  c:='a';
+  wc:=c;
+  c:=wc;
+  if (c<>'a') or
+     (wc<>'a') then
+    halt(8);
+  ss:=wc;
+  wc:=ss[1];
+  if (length(ss)<>1) or
+     (ss[1]<>'a') or
+     (wc<>'a') then
+    halt(9);
+  a:=wc;
+  wc:=a[1];
+  if (length(a)<>1) or
+     (a[1]<>'a') or
+     (wc<>'a') then
+    halt(10);
+
+  wc2:=cwc;
+  if (wc2<>'a') or
+     (wc2<>cwc) then
+    halt(3);
+  ss:=cwc;
+  if (length(ss)<>1) or
+     (ss[1] <> 'a') then
+    halt(4);
+  c:=cwc;
+  if (c<>'a') or
+     (c<>cwc) then
+    halt(13);
+  w:=cwc;
+  if (length(w)<>1) or
+     (w[1] <> 'a') then
+    halt(11);
+  s:=cwc;
+  if (length(s)<>1) or
+     (s[1] <> 'a') then
+    halt(12);
+
+
+  wc:=c2;
+  c:=c2;
+  wc2:=c;
+  if ((c<>c2) and
+      (c<>'?')) or
+     (wc<>c2) or
+     ((wc2<>c2) and
+      (wc2<>'?')) then
+    halt(14);
+  ss:=c2;
+  w:=ss;
+  wc:=w[1];
+  if (length(w)<>1) or
+     (w[1]<>c2) or
+     (wc<>c2) then
+    halt(15);
+  a:=c2;
+  w:=a;
+  wc:=w[1];
+  if (length(w)<>1) or
+     (w[1]<>c2) or
+     (wc<>c2) then
+    halt(16);
+
+  ss:=c3;
+  w:=ss;
+  wc:=w[1];
+  if (length(w)<>1) or
+     (wc <> c2) then
+    halt(17);
+  c:=c3[1];
+  if ((c<>c2) and
+      (c<>'?')) then
+    halt(18);
+  w:=c3;
+  if (length(w)<>1) or
+     (w[1] <> c2) then
+    halt(19);
+  s:=c3;
+  w:=s;
+  if (length(w)<>1) or
+     (w[1] <> c2) then
+    halt(20);
+  ss:=c3;
+  w:=ss;
+  if (length(w)<>1) or
+     (w[1] <> c2) then
+    halt(21);
+
+  wc:=c2;
+  writestr(s,wc);
+  w:=s;
+  if (length(w)<>1) or
+     (w[1]<>c2) then
+    halt(22);
+end.

tests/webtbs/tw7758a.pp

@@ -0,0 +1,19 @@
+{ %norun }
+
+uses
+  {$ifdef unix}
+  cwstring,
+  {$endif}
+  sysutils;
+
+{ just to make sure that no all wide->shortstring compile time conversions }
+{ fail, but only those resulting in data loss                              }
+const
+  cw = widestring('abc');
+  de = 'a'+shortstring(cw);
+  wc = widechar('a');
+  df = shortstring(wc)+'abcd';
+  dg = char(wc)+'abcd';
+
+begin
+end.