paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-11 20:49:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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 -
This commit is contained in:
svenbarth 2016-06-03 21:25:49 +00:00
parent c1afb4b63b
commit a2c9c75e97
13 changed files with 148 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/compinnr.inc
View File

@ -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;

76
compiler/ninl.pas
View File

@ -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

10
compiler/pexpr.pas
View File

@ -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);

27
compiler/pinline.pas
View File

@ -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.

2
compiler/psystem.pas
View File

@ -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;

4
rtl/inc/astrings.inc
View File

@ -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;

17
rtl/inc/compproc.inc
View File

@ -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;

6
rtl/inc/sstrings.inc
View File

@ -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

4
rtl/inc/systemh.inc
View File

@ -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;

2
rtl/inc/ustringh.inc
View File

@ -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}

4
rtl/inc/ustrings.inc
View File

@ -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;

2
rtl/inc/wstringh.inc
View File

@ -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}

4
rtl/inc/wstrings.inc
View File

@ -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;