diff --git a/.gitattributes b/.gitattributes index b200daff3c..808d695f88 100644 --- a/.gitattributes +++ b/.gitattributes @@ -17599,6 +17599,7 @@ tests/webtbs/tw34239.pp svneol=native#text/pascal tests/webtbs/tw34287.pp svneol=native#text/pascal tests/webtbs/tw3429.pp svneol=native#text/plain tests/webtbs/tw3433.pp svneol=native#text/plain +tests/webtbs/tw34332.pp svneol=native#text/pascal tests/webtbs/tw3435.pp svneol=native#text/plain tests/webtbs/tw34380.pp svneol=native#text/plain tests/webtbs/tw3441.pp svneol=native#text/plain diff --git a/compiler/ninl.pas b/compiler/ninl.pas index ee7a17064f..22b0ff7378 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -1790,12 +1790,49 @@ implementation function tinlinenode.handle_copy: tnode; + + procedure do_error(typemismatch:boolean;func:string;fi:tfileposinfo); + + procedure write_dynarray_copy; + begin + MessagePos1(fileinfo,sym_e_param_list,'Copy(Dynamic Array;'+sizesinttype.typename+'=``;'+sizesinttype.typename+'=``);'); + end; + + begin + if typemismatch then + CGMessagePos(fi,type_e_mismatch) + else + CGMessagePos1(fi,parser_e_wrong_parameter_size,'Copy'); + if func='' then + begin + write_system_parameter_lists('fpc_shortstr_copy'); + write_system_parameter_lists('fpc_char_copy'); + write_system_parameter_lists('fpc_unicodestr_copy'); + if tf_winlikewidestring in target_info.flags then + write_system_parameter_lists('fpc_widestr_copy'); + write_system_parameter_lists('fpc_ansistr_copy'); + write_dynarray_copy; + end + else if func='fpc_dynarray_copy' then + write_dynarray_copy + else + write_system_parameter_lists(func); + end; + var paras : tnode; ppn : tcallparanode; paradef : tdef; counter : integer; + minargs, + maxargs : longint; + func : string; begin + if not assigned(left) then + begin + do_error(false,'',fileinfo); + exit(cerrornode.create); + end; result:=nil; { determine copy function to use based on the first argument, also count the number of arguments in this loop } @@ -1810,44 +1847,63 @@ implementation end; set_varstate(ppn.left,vs_read,[vsf_must_be_valid]); paradef:=ppn.left.resultdef; + { the string variants all require 2 or 3 args, only the array one allows less } + minargs:=2; + maxargs:=3; if is_ansistring(paradef) then - // set resultdef to argument def - resultdef:=paradef + begin + // set resultdef to argument def + resultdef:=paradef; + func:='fpc_ansistr_copy'; + end else if (is_chararray(paradef) and (paradef.size>255)) or ((cs_refcountedstrings in current_settings.localswitches) and is_pchar(paradef)) then - // set resultdef to ansistring type since result will be in ansistring codepage - resultdef:=getansistringdef - else - if is_widestring(paradef) then - resultdef:=cwidestringtype - else - if is_unicodestring(paradef) or + begin + // set resultdef to ansistring type since result will be in ansistring codepage + resultdef:=getansistringdef; + func:='fpc_ansistr_copy'; + end + else if is_widestring(paradef) then + begin + resultdef:=cwidestringtype; + func:='fpc_widestr_copy'; + end + else if is_unicodestring(paradef) or is_widechararray(paradef) or is_pwidechar(paradef) then - resultdef:=cunicodestringtype + begin + resultdef:=cunicodestringtype; + func:='fpc_unicodestr_copy'; + end else if is_char(paradef) then - resultdef:=cshortstringtype + begin + resultdef:=cshortstringtype; + func:='fpc_char_copy'; + end else if is_dynamic_array(paradef) then begin - { Only allow 1 or 3 arguments } - if not(counter in [1..3]) then - begin - CGMessage1(parser_e_wrong_parameter_size,'Copy'); - exit; - end; + minargs:=1; resultdef:=paradef; + func:='fpc_dynarray_copy'; + end + else if counter in [2..3] then + begin + resultdef:=cshortstringtype; + func:='fpc_shortstr_copy'; end else - begin - { generic fallback that will give an error if a wrong - type is passed } - if (counter=3) then - resultdef:=cshortstringtype - else - CGMessagePos(ppn.left.fileinfo,type_e_mismatch); - end; + begin + do_error(true,'',ppn.left.fileinfo); + exit(cerrornode.create); + end; + + if (countermaxargs) then + begin + do_error(false,func,fileinfo); + exit(cerrornode.create); + end; end; {$maxfpuregisters 0} diff --git a/compiler/pinline.pas b/compiler/pinline.pas index 1c1364b9de..ef4eee9026 100644 --- a/compiler/pinline.pas +++ b/compiler/pinline.pas @@ -682,7 +682,7 @@ implementation function inline_copy: tnode; begin - result:=inline_copy_insert_delete(in_copy_x,'Copy',true); + result:=inline_copy_insert_delete(in_copy_x,'Copy',false); end; diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc index b4c31bbee5..f4dc1b5597 100644 --- a/rtl/inc/compproc.inc +++ b/rtl/inc/compproc.inc @@ -58,8 +58,8 @@ function fpc_pwidechar_length(p:pwidechar):sizeint; compilerproc; procedure fpc_chararray_to_shortstr(out res : shortstring;const arr: array of char; zerobased: boolean = true); compilerproc; procedure fpc_shortstr_to_chararray(out res: array of char; const src: ShortString); compilerproc; -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; +Function fpc_shortstr_Copy(const s:shortstring;index:SizeInt;count:SizeInt):shortstring;compilerproc{$ifndef VER3_0}:fpc_in_copy_x{$endif VER3_0}; +function fpc_char_copy(c:char;index : SizeInt;count : SizeInt): shortstring;compilerproc{$ifndef VER3_0}:fpc_in_copy_x{$endif VER3_0}; {$ifndef VER3_0} Procedure fpc_shortstr_delete(var s:shortstring;index:SizeInt;count:SizeInt); compilerproc:fpc_in_delete_x_y_z; Procedure fpc_shortstr_insert(const source:shortstring;var s:shortstring;index:SizeInt); compilerproc:fpc_in_insert_x_y_z; @@ -318,7 +318,7 @@ Function fpc_AnsiStr_Compare_equal(const S1,S2 : RawByteString): SizeInt; compil 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; +Function fpc_ansistr_Copy (Const S : RawByteString; Index,Size : SizeInt): RawByteString;compilerproc{$ifndef VER3_0}:fpc_in_copy_x{$endif VER3_0}; {$ifndef VER3_0} Procedure fpc_ansistr_insert (const Source : RawByteString; var S : RawByteString; Index : SizeInt); compilerproc:fpc_in_insert_x_y_z; rtlproc; Procedure fpc_ansistr_delete (var S : RawByteString; Index,Size: SizeInt); compilerproc:fpc_in_delete_x_y_z; rtlproc; @@ -357,7 +357,7 @@ Function fpc_WideStr_Compare_equal(const S1,S2 : WideString): SizeInt; compilerp 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; +Function fpc_widestr_Copy (Const S : WideString; Index,Size : SizeInt) : WideString;compilerproc{$ifndef VER3_0}:fpc_in_copy_x{$endif VER3_0}; {$ifndef VER3_0} Procedure fpc_widestr_insert (Const Source : WideString; Var S : WideString; Index : SizeInt); compilerproc:fpc_in_insert_x_y_z; Procedure fpc_widestr_delete (Var S : WideString; Index,Size: SizeInt); compilerproc:fpc_in_delete_x_y_z; @@ -405,7 +405,7 @@ Function fpc_UnicodeStr_Compare_equal(const S1,S2 : UnicodeString): SizeInt; com 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; +Function fpc_unicodestr_Copy (Const S : UnicodeString; Index,Size : SizeInt) : UnicodeString;compilerproc{$ifndef VER3_0}:fpc_in_copy_x{$endif VER3_0}; {$ifndef VER3_0} Procedure fpc_unicodestr_insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt); compilerproc:fpc_in_insert_x_y_z; Procedure fpc_unicodestr_delete (Var S : UnicodeString; Index,Size: SizeInt); compilerproc:fpc_in_delete_x_y_z; diff --git a/tests/webtbs/tw34332.pp b/tests/webtbs/tw34332.pp new file mode 100644 index 0000000000..096ee08261 --- /dev/null +++ b/tests/webtbs/tw34332.pp @@ -0,0 +1,14 @@ +{ %NORUN } + +program tw34332; + +{$mode objfpc}{$h+} + +var + SS: ShortString; + S: String; +begin + SS := Copy(SS, 1); // << project1.lpr(9,14) Error: Type mismatch + S := Copy(S, 1); // << OK + SS := Copy(SS, 1, 1); // << OK +end.