Convert Insert() and Delete() to intrinsics in preparation for dynamic array support for these two procedures.

Since overloading compilerprocs does not work each procedure got its own unique name, but they are using the new compilerproc extension to map them to the Insert and Delete symbol so that error messages can be shown with the respective name for the procedure declarations instead of fpc_shortstr_delete for example.

git-svn-id: trunk@33895 -

compiler/compinnr.inc

@@ -89,6 +89,8 @@ const
    in_popcnt_x          = 79;
    in_aligned_x         = 80;
    in_setstring_x_y_z   = 81;
+   in_insert_x_y_z      = 82;
+   in_delete_x_y_z      = 83;
 
 { Internal constant functions }
    in_const_sqr        = 100;

compiler/ninl.pas

@@ -99,6 +99,8 @@ interface
           function handle_copy: tnode;
           function handle_box: tnode;
           function handle_unbox: tnode;
+          function handle_insert:tnode;
+          function handle_delete:tnode;
        end;
        tinlinenodeclass = class of tinlinenode;
 
@@ -3286,6 +3288,14 @@ implementation
                   set_varstate(tcallparanode(tcallparanode(tcallparanode(left).right).right).left,vs_read,[vsf_must_be_valid]);
                   resultdef:=tcallparanode(left).left.resultdef;
                 end;
+              in_delete_x_y_z:
+                begin
+                  result:=handle_delete;
+                end;
+              in_insert_x_y_z:
+                begin
+                  result:=handle_insert;
+                end;
               else
                 internalerror(8);
             end;
@@ -4255,6 +4265,72 @@ implementation
          resultdef:=tcallparanode(left).left.resultdef;
        end;
 
+     function tinlinenode.handle_insert: tnode;
+       var
+         procname : String;
+         first,
+         second : tdef;
+       begin
+         { determine the correct function based on the second parameter }
+         first:=tcallparanode(tcallparanode(tcallparanode(left).right).right).left.resultdef;
+         second:=tcallparanode(tcallparanode(left).right).left.resultdef;
+         if is_shortstring(second) then
+           begin
+             if is_char(first) then
+               procname:='fpc_shortstr_insert_char'
+             else
+               procname:='fpc_shortstr_insert';
+           end
+         else if is_unicodestring(second) then
+           procname:='fpc_unicodestr_insert'
+         else if is_widestring(second) then
+           procname:='fpc_widestr_insert'
+         else if is_ansistring(second) then
+           procname:='fpc_ansistr_insert'
+         else
+           begin
+             CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,'Insert');
+             write_system_parameter_lists('fpc_shortstr_insert');
+             write_system_parameter_lists('fpc_shortstr_insert_char');
+             write_system_parameter_lists('fpc_unicodestr_insert');
+             if target_info.system in systems_windows then
+               write_system_parameter_lists('fpc_widestr_insert');
+             write_system_parameter_lists('fpc_ansistr_insert');
+             exit(cerrornode.create);
+           end;
+         result:=ccallnode.createintern(procname,left);
+         left:=nil;
+       end;
+
+     function tinlinenode.handle_delete: tnode;
+       var
+         procname : String;
+         first : tdef;
+       begin
+         { determine the correct function based on the first parameter }
+         first:=tcallparanode(tcallparanode(tcallparanode(left).right).right).left.resultdef;
+         if is_shortstring(first) then
+           procname:='fpc_shortstr_delete'
+         else if is_unicodestring(first) then
+           procname:='fpc_unicodestr_delete'
+         else if is_widestring(first) then
+           procname:='fpc_widestr_delete'
+         else if is_ansistring(first) then
+           procname:='fpc_ansistr_delete'
+         else
+           begin
+             CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,'Delete');
+             write_system_parameter_lists('fpc_shortstr_delete');
+             write_system_parameter_lists('fpc_unicodestr_delete');
+             if target_info.system in systems_windows then
+               write_system_parameter_lists('fpc_widestr_delete');
+             write_system_parameter_lists('fpc_ansistr_delete');
+             exit(cerrornode.create);
+           end;
+         result:=ccallnode.createintern(procname,left);
+         left:=nil;
+       end;
+
 
      function tinlinenode.first_pack_unpack: tnode;
        var

compiler/pexpr.pas

@@ -914,6 +914,16 @@ implementation
             begin
               statement_syssym := inline_setstring;
             end;
+
+          in_delete_x_y_z:
+            begin
+              statement_syssym:=inline_delete;
+            end;
+
+          in_insert_x_y_z:
+            begin
+              statement_syssym:=inline_insert;
+            end;
           else
             internalerror(15);
 

compiler/pinline.pas

@@ -39,6 +39,8 @@ interface
     function inline_initialize : tnode;
     function inline_finalize : tnode;
     function inline_copy : tnode;
+    function inline_insert : tnode;
+    function inline_delete : tnode;
 
 
 implementation
@@ -636,7 +638,7 @@ implementation
       end;
 
 
-    function inline_copy : tnode;
+    function inline_copy_insert_delete(nr:byte;name:string) : tnode;
       var
         paras   : tnode;
         { for easy exiting if something goes wrong }
@@ -648,11 +650,30 @@ implementation
         consume(_RKLAMMER);
         if not assigned(paras) then
           begin
-            CGMessage1(parser_e_wrong_parameter_size,'Copy');
+            CGMessage1(parser_e_wrong_parameter_size,name);
             exit;
           end;
         result.free;
-        result:=cinlinenode.create(in_copy_x,false,paras);
+        result:=cinlinenode.create(nr,false,paras);
+      end;
+
+
+    function inline_copy: tnode;
+      begin
+        result:=inline_copy_insert_delete(in_copy_x,'Copy');
+      end;
+
+
+    function inline_insert: tnode;
+      begin
+        result:=inline_copy_insert_delete(in_insert_x_y_z,'Insert');
       end;
 
+
+    function inline_delete: tnode;
+      begin
+        result:=inline_copy_insert_delete(in_delete_x_y_z,'Delete');
+      end;
+
+
 end.

compiler/psystem.pas

@@ -105,6 +105,8 @@ implementation
         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(csyssym.create('Insert',in_insert_x_y_z));
+        systemunit.insert(csyssym.create('Delete',in_delete_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

@@ -1350,7 +1350,7 @@ begin
 end;
 {$endif CPU16 or CPU8}
 
-Procedure Delete(Var S : RawByteString; Index,Size: SizeInt);
+Procedure {$ifdef VER3_0}Delete{$else}fpc_ansistr_delete{$endif}(Var S : RawByteString; Index,Size: SizeInt);
 Var
   LS : SizeInt;
 begin
@@ -1369,7 +1369,7 @@ begin
 end;
 
 
-Procedure Insert(Const Source : RawByteString; Var S : RawByteString; Index : SizeInt);
+Procedure {$ifdef VER3_0}Insert{$else}fpc_ansistr_insert{$endif}(Const Source : RawByteString; Var S : RawByteString; Index : SizeInt);
 var
   Temp : RawByteString;
   LS : SizeInt;

rtl/inc/compproc.inc

@@ -60,6 +60,11 @@ procedure fpc_shortstr_to_chararray(out res: array of char; const src: ShortStri
 
 Function  fpc_shortstr_Copy(const s:shortstring;index:SizeInt;count:SizeInt):shortstring;compilerproc;
 function  fpc_char_copy(c:char;index : SizeInt;count : SizeInt): shortstring;compilerproc;
+{$ifndef VER3_0}
+Procedure fpc_shortstr_delete(var s:shortstring;index:SizeInt;count:SizeInt); compilerproc:83;
+Procedure fpc_shortstr_insert(const source:shortstring;var s:shortstring;index:SizeInt); compilerproc:82;
+Procedure fpc_shortstr_insert_char(source:Char;var s:shortstring;index:SizeInt); compilerproc:82;
+{$endif VER3_0}
 
 {$ifdef FPC_HAS_FEATURE_DYNARRAYS}
 function fpc_dynarray_copy(psrc : pointer;ti : pointer;
@@ -307,6 +312,10 @@ Procedure fpc_AnsiStr_RangeCheck(p : Pointer; index : SizeInt); compilerproc;
 
 Procedure fpc_AnsiStr_SetLength (Var S : RawByteString; l : SizeInt{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
 Function  fpc_ansistr_Copy (Const S : RawByteString; Index,Size : SizeInt): RawByteString;compilerproc;
+{$ifndef VER3_0}
+Procedure fpc_ansistr_insert (const Source : RawByteString; var S : RawByteString; Index : SizeInt); compilerproc:82; rtlproc;
+Procedure fpc_ansistr_delete (var S : RawByteString; Index,Size: SizeInt); compilerproc:83; rtlproc;
+{$endif VER3_0}
 {$ifdef EXTRAANSISHORT}
 Function fpc_AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): SizeInt; compilerproc;
 {$endif EXTRAANSISHORT}
@@ -342,6 +351,10 @@ Procedure fpc_WideStr_RangeCheck(p: Pointer; index : SizeInt); compilerproc;
 
 Procedure fpc_WideStr_SetLength (Var S : WideString; l : SizeInt); compilerproc;
 Function  fpc_widestr_Copy (Const S : WideString; Index,Size : SizeInt) : WideString;compilerproc;
+{$ifndef VER3_0}
+Procedure fpc_widestr_insert (Const Source : WideString; Var S : WideString; Index : SizeInt); compilerproc:82;
+Procedure fpc_widestr_delete (Var S : WideString; Index,Size: SizeInt); compilerproc:83;
+{$endif VER3_0}
 {$ifndef FPC_WINLIKEWIDESTRING}
 function fpc_widestr_Unique(Var S : Pointer): Pointer; compilerproc;
 {$endif FPC_WINLIKEWIDESTRING}
@@ -386,6 +399,10 @@ Procedure fpc_UnicodeStr_RangeCheck(p: Pointer; index : SizeInt); compilerproc;
 
 Procedure fpc_UnicodeStr_SetLength (Var S : UnicodeString; l : SizeInt); compilerproc;
 Function  fpc_unicodestr_Copy (Const S : UnicodeString; Index,Size : SizeInt) : UnicodeString;compilerproc;
+{$ifndef VER3_0}
+Procedure fpc_unicodestr_insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt); compilerproc:82;
+Procedure fpc_unicodestr_delete (Var S : UnicodeString; Index,Size: SizeInt); compilerproc:83;
+{$endif VER3_0}
 function fpc_unicodestr_Unique(Var S : Pointer): Pointer; compilerproc;
 Function fpc_Char_To_UChar(const c : Char): UnicodeChar; compilerproc;
 Function fpc_UChar_To_Char(const c : UnicodeChar): Char; compilerproc;

rtl/inc/sstrings.inc

@@ -49,7 +49,7 @@ end;
 
 {$ifndef FPC_HAS_SHORTSTR_DELETE}
 {$define FPC_HAS_SHORTSTR_DELETE}
-procedure delete(var s : shortstring;index : SizeInt;count : SizeInt);
+procedure {$ifdef VER3_0}delete{$else}fpc_shortstr_delete{$endif}(var s : shortstring;index : SizeInt;count : SizeInt);
 begin
   if index<=0 then
      exit;
@@ -67,7 +67,7 @@ end;
 
 {$ifndef FPC_HAS_SHORTSTR_INSERT}
 {$define FPC_HAS_SHORTSTR_INSERT}
-procedure insert(const source : shortstring;var s : shortstring;index : SizeInt);
+procedure {$ifdef ver3_0}insert{$else}fpc_shortstr_insert{$endif}(const source : shortstring;var s : shortstring;index : SizeInt);
 var
   cut,srclen,indexlen : SizeInt;
 begin
@@ -101,7 +101,7 @@ end;
 
 {$ifndef FPC_HAS_SHORTSTR_INSERT_CHAR}
 {$define FPC_HAS_SHORTSTR_INSERT_CHAR}
-procedure insert(source : Char;var s : shortstring;index : SizeInt);
+procedure {$ifdef ver3_0}insert{$else}fpc_shortstr_insert_char{$endif}(source : Char;var s : shortstring;index : SizeInt);
 var
   indexlen : SizeInt;
 begin

rtl/inc/systemh.inc

@@ -1127,9 +1127,11 @@ function strlen(p:pchar):sizeint;external name 'FPC_PCHAR_LENGTH';
 function Utf8CodePointLen(P: PAnsiChar; MaxLookAhead: SizeInt; IncludeCombiningDiacriticalMarks: Boolean): SizeInt;
 
 { Shortstring functions }
+{$ifdef VER3_0}
 Procedure Delete(var s:shortstring;index:SizeInt;count:SizeInt);
 Procedure Insert(const source:shortstring;var s:shortstring;index:SizeInt);
 Procedure Insert(source:Char;var s:shortstring;index:SizeInt);
+{$endif VER3_0}
 Function  Pos(const substr:shortstring;const s:shortstring; Offset: Sizeint = 1):SizeInt;
 Function  Pos(C:Char;const s:shortstring; Offset: Sizeint = 1):SizeInt;
 {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
@@ -1180,8 +1182,10 @@ function  pos(const substr : shortstring;c:char; Offset: Sizeint = 1): SizeInt;
 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; Offset: Sizeint = 1) : SizeInt;
 Function  Pos (c : AnsiChar; const s : RawByteString; Offset: Sizeint = 1) : SizeInt;
+{$ifdef VER3_0}
 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}
+{$endif VER3_0}
 Function  StringOfChar(c : Ansichar;l : SizeInt) : AnsiString;
 function  upcase(const s : ansistring) : ansistring;
 function  lowercase(const s : ansistring) : ansistring;

rtl/inc/ustringh.inc

@@ -28,8 +28,10 @@ Function  UpCase(c:UnicodeChar):UnicodeChar;
 Function LowerCase(const s : UnicodeString) : UnicodeString;
 Function  LowerCase(c:UnicodeChar):UnicodeChar;
 
+{$ifdef VER3_0}
 Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
 Procedure Delete (Var S : UnicodeString; Index,Size: SizeInt);
+{$endif VER3_0}
 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}
 

rtl/inc/ustrings.inc

@@ -1265,7 +1265,7 @@ end;
 
 {$ifndef FPC_HAS_DELETE_UNICODESTR}
 {$define FPC_HAS_DELETE_UNICODESTR}
-Procedure Delete (Var S : UnicodeString; Index,Size: SizeInt);
+Procedure {$ifdef VER3_0}Delete{$else}fpc_unicodestr_delete{$endif}(Var S : UnicodeString; Index,Size: SizeInt);
 Var
   LS : SizeInt;
 begin
@@ -1289,7 +1289,7 @@ end;
 
 {$ifndef FPC_HAS_INSERT_UNICODESTR}
 {$define FPC_HAS_INSERT_UNICODESTR}
-Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
+Procedure {$ifdef VER3_0}Insert{$else}fpc_unicodestr_insert{$endif}(Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
 var
   Temp : UnicodeString;
   LS : SizeInt;

rtl/inc/wstringh.inc

@@ -26,8 +26,10 @@ Function Pos (const c : ShortString; Const s : WideString; Offset : SizeInt = 1)
 
 Function UpCase(const s : WideString) : WideString;
 
+{$ifdef VER3_0}
 Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
 Procedure Delete (Var S : WideString; Index,Size: SizeInt);
+{$endif VER3_0}
 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}
 

rtl/inc/wstrings.inc

@@ -679,7 +679,7 @@ end;
 
 
 
-Procedure Delete (Var S : WideString; Index,Size: SizeInt);
+Procedure {$ifdef VER3_0}Delete{$else}fpc_widestr_delete{$endif}(Var S : WideString; Index,Size: SizeInt);
 Var
   LS : SizeInt;
 begin
@@ -699,7 +699,7 @@ begin
 end;
 
 
-Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
+Procedure {$ifdef VER3_0}Insert{$else}fpc_widestr_insert{$endif}(Const Source : WideString; Var S : WideString; Index : SizeInt);
 var
   Temp : WideString;
   LS : SizeInt;