* made setstring() a compiler intrinsic so it can set the compile-time

    code page of ansistrings (mantis #26735)

git-svn-id: trunk@28813 -

compiler/compinnr.inc

@@ -88,6 +88,7 @@ const
    in_unbox_x_y         = 78; { manage platforms: extract from class instance }
    in_popcnt_x          = 79;
    in_aligned_x         = 80;
+   in_setstring_x_y_z   = 81;
 
 { Internal constant functions }
    in_const_sqr        = 100;

compiler/pexpr.pas

@@ -889,6 +889,11 @@ implementation
               { consume the right bracket here for a nicer error position }
               consume(_RKLAMMER);
             end;
+
+          in_setstring_x_y_z:
+            begin
+              statement_syssym := inline_setstring;
+            end;
           else
             internalerror(15);
 

compiler/pinline.pas

@@ -35,6 +35,7 @@ interface
     function new_function : tnode;
 
     function inline_setlength : tnode;
+    function inline_setstring : tnode;
     function inline_initialize : tnode;
     function inline_finalize : tnode;
     function inline_copy : tnode;
@@ -512,6 +513,52 @@ implementation
       end;
 
 
+    function inline_setstring : tnode;
+      var
+        paras, strpara, pcharpara: tnode;
+        procname: string;
+      begin
+        consume(_LKLAMMER);
+        paras:=parse_paras(false,false,_RKLAMMER);
+        consume(_RKLAMMER);
+        if assigned(paras) and
+           assigned(tcallparanode(paras).right) and
+           assigned(tcallparanode(tcallparanode(paras).right).right) then
+          begin
+            do_typecheckpass(tcallparanode(tcallparanode(paras).right).left);
+            do_typecheckpass(tcallparanode(tcallparanode(tcallparanode(paras).right).right).left);
+            pcharpara:=tcallparanode(tcallparanode(paras).right).left;
+            strpara:=tcallparanode(tcallparanode(tcallparanode(paras).right).right).left;
+            if strpara.resultdef.typ=stringdef then
+              begin
+                { if there are three parameters and the first parameter
+                  ( = paras.right.right) is an ansistring, add a codepage
+                  parameter }
+                if is_ansistring(strpara.resultdef) then
+                  paras:=ccallparanode.create(genintconstnode(tstringdef(strpara.resultdef).encoding),paras);
+                procname:='fpc_setstring_'+tstringdef(strpara.resultdef).stringtypname;
+                { decide which version to call based on the second parameter }
+                if not is_shortstring(strpara.resultdef) then
+                  if is_pwidechar(pcharpara.resultdef) or
+                     is_widechar(pcharpara.resultdef) or
+                     ((pcharpara.resultdef.typ=arraydef) and
+                      is_widechar(tarraydef(pcharpara.resultdef).elementdef)) then
+                    procname:=procname+'_pwidechar'
+                  else
+                    procname:=procname+'_pansichar';
+              end;
+          end
+        { default version (for error message) in case of missing parameters }
+        else if m_default_unicodestring in current_settings.modeswitches then
+          procname:='fpc_setstring_unicodestr_pwidechar'
+        else if m_default_ansistring in current_settings.modeswitches then
+          procname:='fpc_setstring_ansistr_pansichar'
+        else
+          procname:='fpc_setstring_shortstr';
+        result:=ccallnode.createintern(procname,paras)
+      end;
+
+
     function inline_initfinal(isinit: boolean): tnode;
       var
         newblock,

compiler/psystem.pas

@@ -104,6 +104,7 @@ implementation
         systemunit.insert(csyssym.create('ObjCSelector',in_objc_selector_x)); { objc only }
         systemunit.insert(csyssym.create('ObjCEncode',in_objc_encode_x)); { objc only }
         systemunit.insert(csyssym.create('Default',in_default_x));
+        systemunit.insert(csyssym.create('SetString',in_setstring_x_y_z));
         systemunit.insert(cconstsym.create_ord('False',constord,0,pasbool8type));
         systemunit.insert(cconstsym.create_ord('True',constord,1,pasbool8type));
       end;

rtl/inc/astrings.inc

@@ -1404,20 +1404,36 @@ end;
 {$endif FPC_HAS_ANSISTR_OF_CHAR}
 
 
-Procedure SetString(Out S : AnsiString; Buf : PAnsiChar; Len : SizeInt); inline;
+{$ifdef FPC_HAS_CPSTRING}
+Procedure fpc_setstring_ansistr_pansichar(out S : RawByteString; Buf : PAnsiChar; Len : SizeInt; cp: TSystemCodePage); rtlproc; compilerproc;
+{$else}
+Procedure SetString(out S : AnsiString; Buf : PAnsiChar; Len : SizeInt);
+{$endif}
 begin
   SetLength(S,Len);
+{$ifdef FPC_HAS_CPSTRING}
+  SetCodePage(S,cp,false);
+{$endif}
   If (Buf<>Nil) then
     fpc_pchar_ansistr_intern_charmove(Buf,0,S,0,Len);
 end;
 
 
-Procedure SetString(Out S : AnsiString; Buf : PWideChar; Len : SizeInt);
+{$ifdef FPC_HAS_CPSTRING}
+Procedure fpc_setstring_ansistr_pwidechar(out S : RawByteString; Buf : PWideChar; Len : SizeInt; cp: TSystemCodePage); rtlproc; compilerproc;
+{$else}
+Procedure SetString(out S : AnsiString; Buf : PWideChar; Len : SizeInt);
+{$endif}
 begin
   if (Buf<>nil) and (Len>0) then
-    widestringmanager.Wide2AnsiMoveProc(Buf,RawByteString(S),DefaultSystemCodePage,Len)
+    widestringmanager.Wide2AnsiMoveProc(Buf,S,{$ifdef FPC_HAS_CPSTRING}cp{$else}DefaultSystemCodePage{$endif},Len)
   else
-    SetLength(S, Len);
+    begin
+      SetLength(S, Len);
+{$ifdef FPC_HAS_CPSTRING}
+      SetCodePage(S,cp,false);
+{$endif}
+    end;
 end;
 
 

rtl/inc/innr.inc

@@ -89,6 +89,7 @@ const
    fpc_in_unbox_x_y         = 78; { manage platforms: extract from class instance }
    fpc_in_popcnt_x          = 79;
    fpc_in_aligned_x         = 80;
+   fpc_in_setstring_x_y_z   = 81;
 
 { Internal constant functions }
    fpc_in_const_sqr        = 100;

rtl/inc/sstrings.inc

@@ -2080,7 +2080,7 @@ end;
 
 {$ifndef FPC_HAS_SETSTRING_SHORTSTR}
 {$define FPC_HAS_SETSTRING_SHORTSTR}
-Procedure SetString (Out S : Shortstring; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_shortstr{$else}SetString{$endif}(Out S : Shortstring; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
 begin
   If Len > High(S) then
     Len := High(S);

rtl/inc/systemh.inc

@@ -1071,10 +1071,16 @@ Function  Pos(const substr:shortstring;const s:shortstring):SizeInt;
 Function  Pos(C:Char;const s:shortstring):SizeInt;
 {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
 Function  Pos(const Substr : ShortString; const Source : RawByteString) : SizeInt;
+
+{$ifdef FPC_HAS_CPSTRING}
+Procedure fpc_setstring_ansistr_pansichar(out S : RawByteString; Buf : PAnsiChar; Len : SizeInt; cp: TSystemCodePage); rtlproc; compilerproc;
+Procedure fpc_setstring_ansistr_pwidechar(out S : RawByteString; Buf : PWideChar; Len : SizeInt; cp: TSystemCodePage); rtlproc; compilerproc;
+{$else}
 Procedure SetString(out S : AnsiString; Buf : PAnsiChar; Len : SizeInt);
 Procedure SetString(out S : AnsiString; Buf : PWideChar; Len : SizeInt);
+{$endif}
 {$endif FPC_HAS_FEATURE_ANSISTRINGS}
-Procedure SetString (out S : Shortstring; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_shortstr{$else}SetString{$endif}(out S : Shortstring; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
 function  ShortCompareText(const S1, S2: shortstring): SizeInt;
 Function  upCase(const s:shortstring):shortstring;
 Function  lowerCase(const s:shortstring):shortstring; overload;

rtl/inc/ustringh.inc

@@ -30,8 +30,8 @@ Function  LowerCase(c:UnicodeChar):UnicodeChar;
 
 Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
 Procedure Delete (Var S : UnicodeString; Index,Size: SizeInt);
-Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt);
-Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_unicodestr_pwidechar{$else}SetString{$endif}(Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_unicodestr_pansichar{$else}SetString{$endif}(Out S : UnicodeString; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
 
 function WideCharToString(S : PWideChar) : UnicodeString;
 function StringToWideChar(const Src : RawByteString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;

rtl/inc/ustrings.inc

@@ -1351,7 +1351,7 @@ end;
 
 {$ifndef FPC_HAS_SETSTRING_UNICODESTR_PUNICODECHAR}
 {$define FPC_HAS_SETSTRING_UNICODESTR_PUNICODECHAR}
-Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_unicodestr_pwidechar{$else}SetString{$endif}(Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
 begin
   SetLength(S,Len);
   If (Buf<>Nil) and (Len>0) then
@@ -1362,7 +1362,7 @@ end;
 
 {$ifndef FPC_HAS_SETSTRING_UNICODESTR_PCHAR}
 {$define FPC_HAS_SETSTRING_UNICODESTR_PCHAR}
-Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_unicodestr_pansichar{$else}SetString{$endif}(Out S : UnicodeString; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
 begin
   If (Buf<>Nil) and (Len>0) then
     widestringmanager.Ansi2UnicodeMoveProc(Buf,DefaultSystemCodePage,S,Len)

rtl/inc/wstringh.inc

@@ -28,8 +28,8 @@ Function UpCase(const s : WideString) : WideString;
 
 Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
 Procedure Delete (Var S : WideString; Index,Size: SizeInt);
-Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
-Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_widestr_pwidechar{$else}SetString{$endif}(Out S : WideString; Buf : PWideChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_widestr_pansichar{$else}SetString{$endif}(Out S : WideString; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
 
 procedure DefaultAnsi2WideMove(source:pchar;cp : TSystemCodePage;var dest:widestring;len:SizeInt);
 

rtl/inc/wstrings.inc

@@ -723,7 +723,7 @@ begin
 end;
 
 
-Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_widestr_pwidechar{$else}SetString{$endif}(Out S : WideString; Buf : PWideChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
 begin
   SetLength(S,Len);
   If (Buf<>Nil) and (Len>0) then
@@ -731,7 +731,7 @@ begin
 end;
 
 
-Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_widestr_pansichar{$else}SetString{$endif}(Out S : WideString; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
 begin
   If (Buf<>Nil) and (Len>0) then
     widestringmanager.Ansi2WideMoveProc(Buf,DefaultSystemCodePage,S,Len)

tests/test/units/sysutils/tencodingtest.pp

@@ -44,6 +44,11 @@ begin
   SetString(S, PAnsiChar(Bytes), Length(Bytes));
   if not CompareMem(Pointer(S), Pointer(Cp866String), Length(S)) then
     halt(1);
+  if StringCodePage(S)<>DefaultSystemCodePage then
+    halt(11);
+  SetString(Cp1251String,pchar(Cp1251String),length(Cp1251String));
+  if StringCodePage(Cp1251String)<>1251 then
+    halt(12);
   U1 := Cp866Encoding.GetString(Bytes);
   U2 := TEncoding.Unicode.GetString(TEncoding.Convert(Cp866Encoding, TEncoding.Unicode, Bytes));
   if U1 <> U2 then