merge r17552 from cpstrnew branch by inoussa:

*In normal procedure "var" and "out" RawByteString parameters does not accept other string types. Procedures with
"compilerproc" directive or the newly added "rtlproc" directive accept that. Please note that it is up to the
procedure coder to ensure the correctness of the code page in that case. The new directive is needed to handle 
the RTL procedures/functions that are not marked as "compilerproc" such as "UniqueString", "Insert" and "Delete".

*Correct "fpc_ansistr_concat" to handle code page correctly.

*Default "ansitring" type is now created with code page set to "0" instead of "65535". Before that change it was 
impossible to distinguish a "RawByteString" with the default "ansistring". At runtime "ansistring" variable'code
page is set to DefaultSystemCodePage

*UniqueString flavor of "SetLength" has been updated to release memory when shrinked to at least 50%, like ansitring
does.

git-svn-id: trunk@19118 -

compiler/defcmp.pas

@@ -43,7 +43,9 @@ interface
           cpo_ignoreuniv,
           cpo_warn_incompatible_univ,
           cpo_ignorevarspez,          // ignore parameter access type
-          cpo_ignoreframepointer      // ignore frame pointer parameter (for assignment-compatibility of global procedures to nested procvars)
+          cpo_ignoreframepointer,     // ignore frame pointer parameter (for assignment-compatibility of global procedures to nested procvars)
+          cpo_compilerproc,
+          cpo_rtlproc
        );
 
        tcompare_paras_options = set of tcompare_paras_option;
@@ -355,8 +357,11 @@ implementation
                         if (tstringdef(def_from).encoding=tstringdef(def_to).encoding) or
                            (tstringdef(def_from).encoding=globals.CP_NONE) or
                            (tstringdef(def_to).encoding=globals.CP_NONE) then
-                          eq:=te_equal
-                        else 
+                         begin
+                           //doconv := tc_string_2_string;
+                           eq:=te_equal;
+                         end
+                        else
                          begin        
                            doconv := tc_string_2_string;
                            if (tstringdef(def_to).encoding=globals.CP_UTF8) then 
@@ -1804,6 +1809,17 @@ implementation
                  if not equal_constsym(tconstsym(currpara1.defaultconstsym),tconstsym(currpara2.defaultconstsym)) then
                    exit;
                end;
+              if not(cpo_compilerproc in cpoptions) and
+                 not(cpo_rtlproc in cpoptions) and
+                 is_ansistring(currpara1.vardef) and
+                 is_ansistring(currpara2.vardef) and
+                 (tstringdef(currpara1.vardef).encoding<>tstringdef(currpara2.vardef).encoding) and
+                 ((tstringdef(currpara1.vardef).encoding=globals.CP_NONE) or
+                  (tstringdef(currpara2.vardef).encoding=globals.CP_NONE)
+                 ) then
+                eq:=te_convert_l1;
+              if eq<lowesteq then
+                lowesteq:=eq;
               inc(i1);
               inc(i2);
               if cpo_ignorehidden in cpoptions then

compiler/htypechk.pas

@@ -1997,6 +1997,7 @@ implementation
         st    : TSymtable;
         contextstructdef : tabstractrecorddef;
         ProcdefOverloadList : TFPObjectList;
+        cpoptions : tcompare_paras_options;
       begin
         FCandidateProcs:=nil;
 
@@ -2086,11 +2087,16 @@ implementation
                ) then
               begin
                 { don't add duplicates, only compare visible parameters for the user }
+                cpoptions:=[cpo_ignorehidden];
+                if (po_compilerproc in pd.procoptions) then
+                  cpoptions:=cpoptions+[cpo_compilerproc];
+                if (po_rtlproc in pd.procoptions) then
+                  cpoptions:=cpoptions+[cpo_rtlproc];
                 found:=false;
                 hp:=FCandidateProcs;
                 while assigned(hp) do
                   begin
-                    if (compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,[cpo_ignorehidden])>=te_equal) and
+                    if (compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,cpoptions)>=te_equal) and
                        (not(po_objc in pd.procoptions) or
                         (pd.messageinf.str^=hp^.data.messageinf.str^)) then
                       begin
@@ -2412,7 +2418,17 @@ implementation
               else
               { generic type comparision }
                begin
-                 eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,cdoptions);
+                 if not(po_compilerproc in hp^.data.procoptions) and
+                    not(po_rtlproc in hp^.data.procoptions) and
+                    is_ansistring(currpara.vardef) and
+                    is_ansistring(currpt.left.resultdef) and
+                    (tstringdef(currpara.vardef).encoding<>tstringdef(currpt.left.resultdef).encoding) and
+                    ((tstringdef(currpara.vardef).encoding=globals.CP_NONE) or
+                     (tstringdef(currpt.left.resultdef).encoding=globals.CP_NONE)
+                    ) then
+                   eq:=te_convert_l1
+                 else
+                   eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,cdoptions);
 
                  { when the types are not equal we need to check
                    some special case for parameter passing }

compiler/nadd.pas

@@ -1983,6 +1983,7 @@ implementation
         newstatement : tstatementnode;
         tempnode (*,tempnode2*) : ttempcreatenode;
         cmpfuncname: string;
+        para: tcallparanode;
       begin
         { when we get here, we are sure that both the left and the right }
         { node are both strings of the same stringtype (JM)              }
@@ -2011,11 +2012,26 @@ implementation
                   (aktassignmentnode.left.resultdef=resultdef) and
                   valid_for_var(aktassignmentnode.left,false) then
                 begin
-                  result:=ccallnode.createintern('fpc_'+
-                    tstringdef(resultdef).stringtypname+'_concat',
-                    ccallparanode.create(right,
-                    ccallparanode.create(left,
-                    ccallparanode.create(aktassignmentnode.left.getcopy,nil))));
+                  para:=ccallparanode.create(
+                          right,
+                          ccallparanode.create(
+                            left,
+                            ccallparanode.create(aktassignmentnode.left.getcopy,nil)
+                          )
+                        );
+                  if is_ansistring(resultdef) then
+                    para:=ccallparanode.create(
+                            cordconstnode.create(
+                              tstringdef(resultdef).encoding,
+                              u16inttype,
+                              true
+                            ),
+                            para
+                          );
+                  result:=ccallnode.createintern(
+                            'fpc_'+tstringdef(resultdef).stringtypname+'_concat',
+                            para
+                          );
                   include(aktassignmentnode.flags,nf_assign_done_in_right);
                   firstpass(result);
                 end
@@ -2024,11 +2040,29 @@ implementation
                   result:=internalstatements(newstatement);
                   tempnode:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
                   addstatement(newstatement,tempnode);
-                  addstatement(newstatement,ccallnode.createintern('fpc_'+
-                    tstringdef(resultdef).stringtypname+'_concat',
-                    ccallparanode.create(right,
-                    ccallparanode.create(left,
-                    ccallparanode.create(ctemprefnode.create(tempnode),nil)))));
+                  para:=ccallparanode.create(
+                          right,
+                          ccallparanode.create(
+                            left,
+                            ccallparanode.create(ctemprefnode.create(tempnode),nil)
+                          )
+                        );
+                  if is_ansistring(resultdef) then
+                    para:=ccallparanode.create(
+                            cordconstnode.create(
+                              tstringdef(resultdef).encoding,
+                              u16inttype,
+                              true
+                            ),
+                            para
+                          );
+                  addstatement(
+                    newstatement,
+                    ccallnode.createintern(
+                      'fpc_'+tstringdef(resultdef).stringtypname+'_concat',
+                      para
+                    )
+                  );
                   addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
                   addstatement(newstatement,ctemprefnode.create(tempnode));
                 end;

compiler/pdecsub.pas

@@ -2140,7 +2140,7 @@ type
    end;
 const
   {Should contain the number of procedure directives we support.}
-  num_proc_directives=42;
+  num_proc_directives=43;
   proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
    (
     (
@@ -2533,6 +2533,15 @@ const
       mutexclpocall : [pocall_internproc];
       mutexclpotype : [];
       mutexclpo     : [po_exports,po_interrupt,po_external,po_inline]
+    ),(
+      idtok:_RTLPROC;
+      pd_flags : [pd_interface,pd_implemen,pd_body,pd_notobjintf];
+      handler  : nil;
+      pocall   : pocall_none;
+      pooption : [po_rtlproc];
+      mutexclpocall : [];
+      mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
+      mutexclpo     : [po_interrupt]
     )
    );
 

compiler/symconst.pas

@@ -314,7 +314,8 @@ type
       (when calling a regular procedure using the above convention, it will
        simply not see the frame pointer parameter, and since the caller cleans
        up the stack will also remain balanced) }
-    po_delphi_nested_cc
+    po_delphi_nested_cc,
+    po_rtlproc
   );
   tprocoptions=set of tprocoption;
 

compiler/symdef.pas

@@ -1447,7 +1447,7 @@ implementation
       begin
          inherited create(stringdef);
          stringtype:=st_ansistring;
-         encoding:=65535;
+         encoding:=0;
          len:=-1;
          savesize:=sizeof(pint);
       end;

compiler/tokens.pas

@@ -204,6 +204,7 @@ type
     _PRIVATE,
     _PROGRAM,
     _R12BASE,
+    _RTLPROC,
     _SECTION,
     _STDCALL,
     _SYSCALL,
@@ -500,6 +501,7 @@ const
       (str:'PRIVATE'       ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'PROGRAM'       ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'R12BASE'       ;special:false;keyword:m_none;op:NOTOKEN),   { Syscall variation on MorphOS }
+      (str:'RTLPROC'       ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'SECTION'       ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'STDCALL'       ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'SYSCALL'       ;special:false;keyword:m_none;op:NOTOKEN),

rtl/inc/astrings.inc

@@ -207,7 +207,7 @@ end;
 
 {$else STR_CONCAT_PROCS}
 
-procedure fpc_AnsiStr_Concat (var DestS:RawByteString;const S1,S2 : RawByteString); compilerproc;
+procedure fpc_AnsiStr_Concat (var DestS:RawByteString;const S1,S2 : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
 Var
   Size,Location : SizeInt;
   same : boolean;
@@ -216,13 +216,20 @@ Var
 begin
   { if codepages are differ then concat using unicodestring }
   S1CP:=StringCodePage(S1);
-  if S1CP=$ffff then
+  if (S1CP=$ffff) or (S1CP=0) then
     S1CP:=DefaultSystemCodePage;
   S2CP:=StringCodePage(S2);
-  if S2CP=$ffff then
+  if (S2CP=$ffff) or (S2CP=0) then
     S2CP:=DefaultSystemCodePage;
+{$ifdef FPC_HAS_CPSTRING}
+  if (Pointer(DestS)=nil) then
+    DestCP:=cp
+  else
+    DestCP:=StringCodePage(DestS);
+{$else FPC_HAS_CPSTRING}
   DestCP:=StringCodePage(DestS);
-  if DestCP=$ffff then
+{$endif FPC_HAS_CPSTRING}
+  if (DestCP=$ffff) or (DestCP=0) then
     DestCP:=DefaultSystemCodePage;
   if (S1CP<>DestCP) or (S2CP<>DestCP) then
     begin
@@ -264,6 +271,7 @@ begin
     begin
       DestS:='';
       SetLength(DestS,Size+Location);
+      SetCodePage(DestS,DestCP,false);
       Move(Pointer(S1)^,Pointer(DestS)^,Location);
       Move(Pointer(S2)^,(Pointer(DestS)+Location)^,Size+1);
     end;
@@ -281,6 +289,7 @@ Var
   U           : UnicodeString;
   sameCP      : Boolean;
   tmpStr      : RawByteString;
+  tmpCP       : TSystemCodePage;
 begin
   if high(sarr)=0 then
     begin
@@ -295,7 +304,7 @@ begin
 {$else FPC_HAS_CPSTRING}
   DestCP:=StringCodePage(DestS);
 {$endif FPC_HAS_CPSTRING}
-  if (DestCP=$ffff) then
+  if (DestCP=$ffff) or (DestCP=0) then
     DestCP:=DefaultSystemCodePage;
   sameCP:=true;
   lowstart:=low(sarr);
@@ -311,7 +320,8 @@ begin
     begin
       U:='';
       for i:=lowstart to high(sarr) do begin
-        if (StringCodePage(sarr[i]) = $ffff) then
+        tmpCP:=StringCodePage(sarr[i]);
+        if (tmpCP=$ffff) or (tmpCP=0) then
           begin
             tmpStr:=sarr[i];
             SetCodePage(tmpStr,DefaultSystemCodePage,False);
@@ -619,10 +629,10 @@ begin
   else
     begin
       r1:=S1;
-      if (cp1=$ffff) then
+      if (cp1=$ffff) or (cp1=0) then
         SetCodePage(r1,DefaultSystemCodePage,false);
       r2:=S2;
-      if (cp2=$ffff) then
+      if (cp2=$ffff) or (cp2=0) then
         SetCodePage(r2,DefaultSystemCodePage,false);
       //convert them to utf8 then compare
       SetCodePage(r1,65001);
@@ -662,10 +672,10 @@ begin
   else
     begin
       r1:=S1;
-      if (cp1=$ffff) then
+      if (cp1=$ffff) or (cp1=0) then
         SetCodePage(r1,DefaultSystemCodePage,false);
       r2:=S2;
-      if (cp2=$ffff) then
+      if (cp2=$ffff) or (cp2=0) then
         SetCodePage(r2,DefaultSystemCodePage,false);
       Result:=widestringmanager.CompareTextUnicodeStringProc(UnicodeString(r1),UnicodeString(r2));
     end;
@@ -710,6 +720,8 @@ begin
          GetMem(Pointer(S),AnsiRecLen+L);
          PAnsiRec(S)^.Ref:=1;
 {$ifdef FPC_HAS_CPSTRING}
+         if (cp=0) then
+           cp:=DefaultSystemCodePage;
          PAnsiRec(S)^.CodePage:=cp;
 {$else}
          PAnsiRec(S)^.CodePage:=DefaultSystemCodePage;
@@ -1156,7 +1168,7 @@ end;
 
 {$endif CPU64}
 
-Procedure Delete (Var S : AnsiString; Index,Size: SizeInt);
+Procedure Delete (Var S : RawByteString; Index,Size: SizeInt);
 Var
   LS : SizeInt;
 begin
@@ -1175,9 +1187,9 @@ begin
 end;
 
 
-Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : SizeInt);
+Procedure Insert (Const Source : RawByteString; Var S : RawByteString; Index : SizeInt);
 var
-  Temp : AnsiString;
+  Temp : RawByteString;
   LS : SizeInt;
 begin
   If Length(Source)=0 then

rtl/inc/compproc.inc

@@ -249,7 +249,7 @@ Procedure fpc_ansistr_decr_ref (Var S : Pointer); compilerproc;
 Procedure fpc_ansistr_incr_ref (S : Pointer); compilerproc;
 Procedure fpc_AnsiStr_Assign (Var DestS : Pointer;S2 : Pointer); compilerproc;
 {$ifdef STR_CONCAT_PROCS}
-Procedure fpc_AnsiStr_Concat (Var DestS : RawByteString;const S1,S2 : RawByteString); compilerproc;
+Procedure fpc_AnsiStr_Concat (Var DestS : RawByteString;const S1,S2 : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
 Procedure fpc_AnsiStr_Concat_multi (Var DestS : RawByteString;const sarr:array of RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
 {$else STR_CONCAT_PROCS}
 function fpc_AnsiStr_Concat (const S1,S2 : AnsiString): AnsiString; compilerproc;

rtl/inc/systemh.inc

@@ -880,11 +880,11 @@ function  pos(const substr : shortstring;c:char): SizeInt;
 ****************************************************************************}
 
 {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
-Procedure UniqueString(var S : AnsiString);external name 'FPC_ANSISTR_UNIQUE';
+Procedure UniqueString(var S : RawByteString);{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}external name 'FPC_ANSISTR_UNIQUE';
 Function  Pos (const Substr : RawByteString; const Source : RawByteString) : SizeInt;
 Function  Pos (c : Char; const s : RawByteString) : SizeInt;
-Procedure Insert (const Source : AnsiString; var S : AnsiString; Index : SizeInt);
-Procedure Delete (var S : AnsiString; Index,Size: SizeInt);
+Procedure Insert (const Source : RawByteString; var S : RawByteString; Index : SizeInt);{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}
+Procedure Delete (var S : RawByteString; Index,Size: SizeInt);{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}
 Function  StringOfChar(c : char;l : SizeInt) : AnsiString;
 function  upcase(const s : ansistring) : ansistring;
 function  lowercase(const s : ansistring) : ansistring;

rtl/inc/ustrings.inc

@@ -320,13 +320,13 @@ Var
 {$endif FPC_HAS_CPSTRING}
 begin
 {$ifndef FPC_HAS_CPSTRING}
-  cp:=$ffff;
+  cp:=DefaultSystemCodePage;
 {$endif FPC_HAS_CPSTRING}
   result:='';
   Size:=Length(S2);
   if Size>0 then
   begin
-    if cp=$ffff then
+    if (cp=$ffff) or (cp=0) then
       cp:=DefaultSystemCodePage;
     widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(S2)),result,cp,Size);
   end;
@@ -346,7 +346,7 @@ begin
   if Size>0 then
   begin
     cp:=StringCodePage(S2);
-    if cp=$ffff then
+    if (cp=$ffff) or (cp=0) then
       cp:=DefaultSystemCodePage;
     widestringmanager.Ansi2UnicodeMoveProc(PChar(S2),cp,result,Size);
   end;
@@ -375,7 +375,7 @@ var
 {$endif FPC_HAS_CPSTRING}
 begin
 {$ifndef FPC_HAS_CPSTRING}
-  cp:=$ffff;
+  cp:=DefaultSystemCodePage;
 {$endif FPC_HAS_CPSTRING}
   result:='';
   if p=nil then
@@ -465,7 +465,7 @@ var
 {$endif FPC_HAS_CPSTRING}
 begin
 {$ifndef FPC_HAS_CPSTRING}
-  cp:=$ffff;
+  cp:=DefaultSystemCodePage;
 {$endif FPC_HAS_CPSTRING}
   result:='';
   if p=nil then
@@ -808,9 +808,9 @@ var
 {$endif FPC_HAS_CPSTRING}
 begin
 {$ifndef FPC_HAS_CPSTRING}
-  cp:=$ffff;
+  cp:=DefaultSystemCodePage;
 {$endif FPC_HAS_CPSTRING}     
-  if cp=$ffff then
+  if (cp=$ffff) or (cp=0) then
     cp:=DefaultSystemCodePage;
   widestringmanager.Unicode2AnsiMoveProc(@c, fpc_UChar_To_AnsiStr, cp, 1);
 end;
@@ -939,7 +939,7 @@ var
 {$endif FPC_HAS_CPSTRING}
 begin
 {$ifndef FPC_HAS_CPSTRING}
-  cp:=$ffff;
+  cp:=DefaultSystemCodePage;
 {$endif FPC_HAS_CPSTRING}
   if (zerobased) then
     begin
@@ -1052,7 +1052,7 @@ var
 {$endif FPC_HAS_CPSTRING}
 begin
 {$ifndef FPC_HAS_CPSTRING}
-  cp:=$ffff;
+  cp:=DefaultSystemCodePage;
 {$endif FPC_HAS_CPSTRING}
   if (zerobased) then
     begin
@@ -1389,6 +1389,7 @@ Procedure fpc_UnicodeStr_SetLength(Var S : UnicodeString; l : SizeInt);[Public,A
 Var
   Temp : Pointer;
   movelen: SizeInt;
+  lens, lena : SizeUInt;
 begin
    if (l>0) then
     begin
@@ -1401,8 +1402,10 @@ begin
         if (PUnicodeRec(Pointer(S)-UnicodeFirstOff)^.Ref = 1) then
           begin
             Dec(Pointer(S),UnicodeFirstOff);
-            if SizeUInt(L*sizeof(UnicodeChar)+UnicodeRecLen)>MemSize(Pointer(S)) then
-              reallocmem(pointer(S), L*sizeof(UnicodeChar)+UnicodeRecLen);
+            lens:=MemSize(Pointer(s));
+            lena:=SizeUInt(L*sizeof(UnicodeChar)+UnicodeRecLen);
+            if (lena>lens) or ((lens>32) and (lena<=(lens div 2))) then
+              reallocmem(pointer(S), lena);
             Inc(Pointer(S), UnicodeFirstOff);
         end
       else

rtl/inc/wstrings.inc

@@ -272,13 +272,13 @@ Var
 {$endif FPC_HAS_CPSTRING}
 begin
 {$ifndef FPC_HAS_CPSTRING}
-  cp:=$ffff;
+  cp:=DefaultSystemCodePage;
 {$endif FPC_HAS_CPSTRING}
   result:='';
   Size:=Length(S2);
   if Size>0 then
   begin
-    if cp=$ffff then
+    if (cp=$ffff) or (cp=0) then
       cp:=DefaultSystemCodePage;
     widestringmanager.Wide2AnsiMoveProc(PWideChar(Pointer(S2)),result,cp,Size);
   end;
@@ -298,7 +298,7 @@ begin
   if Size>0 then
   begin
     cp:=StringCodePage(S2);
-    if cp=$ffff then
+    if (cp=$ffff) or (cp=0) then
       cp:=DefaultSystemCodePage;
     widestringmanager.Ansi2WideMoveProc(PChar(S2),cp,result,Size);
   end;