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

* string constants are now array of char until

Browse Source 
they are converted to a specific string type

git-svn-id: trunk@1254 -
This commit is contained in:
peter 2005-10-02 11:08:58 +00:00
parent 468c2476de
commit edf553a223
18 changed files with 356 additions and 422 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -6310,6 +6310,7 @@ tests/webtbs/tw4308.pp svneol=native#text/plain
tests/webtbs/tw4336.pp svneol=native#text/plain
tests/webtbs/tw4350.pp svneol=native#text/plain
tests/webtbs/tw4388.pp svneol=native#text/plain
tests/webtbs/tw4390.pp svneol=native#text/plain
tests/webtbs/tw4398.pp svneol=native#text/plain
tests/webtbs/ub1873.pp svneol=native#text/plain
tests/webtbs/ub1883.pp svneol=native#text/plain

27
compiler/aasmtai.pas
View File

@ -270,8 +270,7 @@ interface
{ extra len so the string can contain an \0 }
len : longint;
constructor Create(const _str : string);
constructor Create_pchar(_str : pchar);
constructor Create_length_pchar(_str : pchar;length : longint);
constructor Create_pchar(_str : pchar;length : longint);
destructor Destroy;override;
constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
@ -1478,7 +1477,6 @@ implementation
****************************************************************************}
constructor tai_string.Create(const _str : string);
begin
inherited Create;
typ:=ait_string;
@ -1487,17 +1485,8 @@ implementation
strpcopy(str,_str);
end;
constructor tai_string.Create_pchar(_str : pchar);
begin
inherited Create;
typ:=ait_string;
str:=_str;
len:=strlen(_str);
end;
constructor tai_string.Create_length_pchar(_str : pchar;length : longint);
constructor tai_string.Create_pchar(_str : pchar;length : longint);
begin
inherited Create;
typ:=ait_string;
@ -1505,12 +1494,11 @@ implementation
len:=length;
end;
destructor tai_string.destroy;
destructor tai_string.destroy;
begin
{ you can have #0 inside the strings so }
if str<>nil then
freemem(str,len+1);
freemem(str);
inherited Destroy;
end;
@ -1519,9 +1507,8 @@ implementation
begin
inherited ppuload(t,ppufile);
len:=ppufile.getlongint;
getmem(str,len+1);
getmem(str,len);
ppufile.getdata(str^,len);
str[len]:=#0;
end;
@ -1538,8 +1525,8 @@ implementation
p : tlinkedlistitem;
begin
p:=inherited getcopy;
getmem(tai_string(p).str,len+1);
move(str^,tai_string(p).str^,len+1);
getmem(tai_string(p).str,len);
move(str^,tai_string(p).str^,len);
getcopy:=p;
end;

4
compiler/cresstr.pas
View File

@ -157,7 +157,7 @@ procedure Tresourcestrings.CreateResourceStringList;
getmem(s,len+1);
move(value^,s^,len);
s[len]:=#0;
asmlist[al_const].concat(tai_string.create_length_pchar(s,len));
asmlist[al_const].concat(tai_string.create_pchar(s,len));
asmlist[al_const].concat(tai_const.create_8bit(0));
end;
{ append Current value (nil) and hash...}
@ -175,7 +175,7 @@ procedure Tresourcestrings.CreateResourceStringList;
getmem(s,l+1);
move(Name[1],s^,l);
s[l]:=#0;
asmlist[al_const].concat(tai_string.create_length_pchar(s,l));
asmlist[al_const].concat(tai_string.create_pchar(s,l));
asmlist[al_const].concat(tai_const.create_8bit(0));
end;
end;

140
compiler/defcmp.pas
View File

@ -49,6 +49,7 @@ interface
tc_pchar_2_string,
tc_cchar_2_pchar,
tc_cstring_2_pchar,
tc_cstring_2_int,
tc_ansistring_2_pchar,
tc_string_2_chararray,
tc_chararray_2_string,
@ -266,6 +267,15 @@ implementation
doconv:=tc_int_2_int;
end;
end;
arraydef :
begin
if (m_mac in aktmodeswitches) and
(fromtreetype=stringconstn) then
begin
eq:=te_convert_l3;
doconv:=tc_cstring_2_int;
end;
end;
end;
end;
@ -277,7 +287,9 @@ implementation
{ Constant string }
if (fromtreetype=stringconstn) then
begin
if (tstringdef(def_from).string_typ=tstringdef(def_to).string_typ) then
{ we can change the stringconst node }
if (tstringdef(def_from).string_typ=st_conststring) or
(tstringdef(def_from).string_typ=tstringdef(def_to).string_typ) then
eq:=te_equal
else
begin
@ -285,14 +297,11 @@ implementation
{ Don't prefer conversions from widestring to a
normal string as we can loose information }
if tstringdef(def_from).string_typ=st_widestring then
eq:=te_convert_l1
eq:=te_convert_l3
else if tstringdef(def_to).string_typ=st_widestring then
eq:=te_convert_l2
else
begin
if tstringdef(def_to).string_typ=st_widestring then
eq:=te_convert_l1
else
eq:=te_equal; { we can change the stringconst node }
end;
eq:=te_equal;
end;
end
else
@ -350,36 +359,55 @@ implementation
{ array of char to string, the length check is done by the firstpass of this node }
if is_chararray(def_from) or is_open_chararray(def_from) then
begin
doconv:=tc_chararray_2_string;
if is_open_array(def_from) then
{ "Untyped" stringconstn is an array of char }
if fromtreetype=stringconstn then
begin
if is_ansistring(def_to) then
eq:=te_convert_l1
else if is_widestring(def_to) then
doconv:=tc_string_2_string;
{ prefered string type depends on the $H switch }
if not(cs_ansistrings in aktlocalswitches) and
(tstringdef(def_to).string_typ=st_shortstring) then
eq:=te_equal
else if (cs_ansistrings in aktlocalswitches) and
(tstringdef(def_to).string_typ=st_ansistring) then
eq:=te_equal
else if tstringdef(def_to).string_typ=st_widestring then
eq:=te_convert_l3
else
eq:=te_convert_l2;
eq:=te_convert_l1;
end
else
begin
if is_shortstring(def_to) then
begin
{ Only compatible with arrays that fit
smaller than 255 chars }
if (def_from.size <= 255) then
eq:=te_convert_l1;
end
else if is_ansistring(def_to) then
begin
if (def_from.size > 255) then
eq:=te_convert_l1
else
eq:=te_convert_l2;
end
else if is_widestring(def_to) then
eq:=te_convert_l3
else
eq:=te_convert_l2;
doconv:=tc_chararray_2_string;
if is_open_array(def_from) then
begin
if is_ansistring(def_to) then
eq:=te_convert_l1
else if is_widestring(def_to) then
eq:=te_convert_l3
else
eq:=te_convert_l2;
end
else
begin
if is_shortstring(def_to) then
begin
{ Only compatible with arrays that fit
smaller than 255 chars }
if (def_from.size <= 255) then
eq:=te_convert_l1;
end
else if is_ansistring(def_to) then
begin
if (def_from.size > 255) then
eq:=te_convert_l1
else
eq:=te_convert_l2;
end
else if is_widestring(def_to) then
eq:=te_convert_l3
else
eq:=te_convert_l2;
end;
end;
end
else
@ -629,6 +657,14 @@ implementation
eq:=te_convert_l1;
end;
end
else
{ to array of char, from "Untyped" stringconstn (array of char) }
if (fromtreetype=stringconstn) and
is_chararray(def_to) then
begin
eq:=te_convert_l1;
doconv:=tc_string_2_chararray;
end
else
{ other arrays }
begin
@ -752,7 +788,7 @@ implementation
(is_pchar(def_to) or is_pwidechar(def_to)) then
begin
doconv:=tc_cstring_2_pchar;
eq:=te_convert_l1;
eq:=te_convert_l2;
end
else
if cdo_explicit in cdoptions then
@ -811,21 +847,35 @@ implementation
end;
arraydef :
begin
{ chararray to pointer }
if (is_zero_based_array(def_from) or
is_open_array(def_from)) and
equal_defs(tarraydef(def_from).elementtype.def,tpointerdef(def_to).pointertype.def) then
{ string constant (which can be part of array constructor)
to zero terminated string constant }
if (fromtreetype in [arrayconstructorn,stringconstn]) and
(is_pchar(def_to) or is_pwidechar(def_to)) then
begin
doconv:=tc_array_2_pointer;
eq:=te_convert_l1;
doconv:=tc_cstring_2_pchar;
eq:=te_convert_l2;
end
else
{ dynamic array to pointer, delphi only }
if (m_delphi in aktmodeswitches) and
is_dynamic_array(def_from) then
begin
eq:=te_equal;
end;
{ chararray to pointer }
if (is_zero_based_array(def_from) or
is_open_array(def_from)) and
equal_defs(tarraydef(def_from).elementtype.def,tpointerdef(def_to).pointertype.def) then
begin
doconv:=tc_array_2_pointer;
{ don't prefer the pchar overload when a constant
string was passed }
if fromtreetype=stringconstn then
eq:=te_convert_l2
else
eq:=te_convert_l1;
end
else
{ dynamic array to pointer, delphi only }
if (m_delphi in aktmodeswitches) and
is_dynamic_array(def_from) then
begin
eq:=te_equal;
end;
end;
pointerdef :
begin

27
compiler/nadd.pas
View File

@ -558,7 +558,7 @@ implementation
begin
case nodetype of
addn :
t:=cstringconstnode.createpchar(concatansistrings(s1,s2,l1,l2),l1+l2);
t:=cstringconstnode.createpchar(concatansistrings(s1,s2,l1,l2),l1+l2,st_conststring);
ltn :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<0),booltype,true);
lten :
@ -1086,10 +1086,17 @@ implementation
end;
end
{ pointer comparision and subtraction }
else if ((rd.deftype=pointerdef) and (ld.deftype=pointerdef)) or
else if (
(rd.deftype=pointerdef) and (ld.deftype=pointerdef)
) or
{ compare pchar to char arrays by addresses like BP/Delphi }
((is_pchar(ld) or (lt=niln)) and is_chararray(rd)) or
((is_pchar(rd) or (rt=niln)) and is_chararray(ld)) then
(
(nodetype in [equaln,unequaln]) and
(
((is_pchar(ld) or (lt=niln)) and is_chararray(rd)) or
((is_pchar(rd) or (rt=niln)) and is_chararray(ld))
)
) then
begin
{ convert char array to pointer }
if is_chararray(rd) then
@ -1325,16 +1332,16 @@ implementation
if not assigned(hsym) then
internalerror(200412043);
{ For methodpointers compare only tmethodpointer.proc }
if (rd.deftype=procvardef) and
if (rd.deftype=procvardef) and
(not tprocvardef(rd).is_addressonly) then
begin
begin
right:=csubscriptnode.create(
hsym,
ctypeconvnode.create_internal(right,methodpointertype));
end;
if (ld.deftype=procvardef) and
(not tprocvardef(ld).is_addressonly) then
begin
end;
if (ld.deftype=procvardef) and
(not tprocvardef(ld).is_addressonly) then
begin
left:=csubscriptnode.create(
hsym,
ctypeconvnode.create_internal(left,methodpointertype));

8
compiler/ncal.pas
View File

@ -316,6 +316,14 @@ type
begin
if (paradef.deftype<>arraydef) then
internalerror(200405241);
{ passing a string to an array of char }
if (p.nodetype=stringconstn) then
begin
len:=str_length(p);
if len>0 then
dec(len);
end
else
{ handle special case of passing an single array to an array of array }
if compare_defs(tarraydef(paradef).elementtype.def,p.resulttype.def,nothingn)>=te_equal then
len:=0

49
compiler/ncgcnv.pas
View File

@ -33,6 +33,7 @@ interface
tcgtypeconvnode = class(ttypeconvnode)
procedure second_int_to_int;override;
procedure second_cstring_to_pchar;override;
procedure second_cstring_to_int;override;
procedure second_string_to_chararray;override;
procedure second_array_to_pointer;override;
procedure second_pointer_to_array;override;
@ -136,17 +137,18 @@ interface
begin
location_reset(location,LOC_REGISTER,OS_ADDR);
case tstringdef(left.resulttype.def).string_typ of
st_conststring :
begin
location.register:=cg.getaddressregister(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,location.register);
end;
st_shortstring :
begin
inc(left.location.reference.offset);
location.register:=cg.getaddressregister(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,location.register);
end;
{$ifdef ansistring_bits}
st_ansistring16,st_ansistring32,st_ansistring64 :
{$else}
st_ansistring :
{$endif}
begin
if (left.nodetype=stringconstn) and
(str_length(left)=0) then
@ -180,9 +182,6 @@ interface
else
begin
location.register:=cg.getintregister(exprasmlist,OS_INT);
{$ifdef fpc}
{$warning Todo: convert widestrings to ascii when typecasting them to pchars}
{$endif}
cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_INT,left.location.reference,
location.register);
end;
@ -191,26 +190,24 @@ interface
end;
procedure tcgtypeconvnode.second_string_to_chararray;
var
arrsize: longint;
procedure tcgtypeconvnode.second_cstring_to_int;
begin
with tarraydef(resulttype.def) do
arrsize := highrange-lowrange+1;
if (left.nodetype = stringconstn) and
{ left.length+1 since there's always a terminating #0 character (JM) }
(tstringconstnode(left).len+1 >= arrsize) and
(tstringdef(left.resulttype.def).string_typ=st_shortstring) then
begin
location_copy(location,left.location);
inc(location.reference.offset);
exit;
end
else
{ should be handled already in resulttype pass (JM) }
internalerror(200108292);
{ this can't happen because constants are already processed in
pass 1 }
internalerror(200510013);
end;
procedure tcgtypeconvnode.second_string_to_chararray;
begin
if (left.nodetype = stringconstn) and
(tstringdef(left.resulttype.def).string_typ=st_conststring) then
begin
location_copy(location,left.location);
exit;
end;
{ should be handled already in resulttype pass (JM) }
internalerror(200108292);
end;

196
compiler/ncgcon.pas
View File

@ -248,11 +248,7 @@ implementation
i,mylength : longint;
begin
{ for empty ansistrings we could return a constant 0 }
{$ifdef ansistring_bits}
if (st_type in [st_ansistring16,st_ansistring32,st_ansistring64,st_widestring]) and (len=0) then
{$else}
if (st_type in [st_ansistring,st_widestring]) and (len=0) then
{$endif}
begin
location_reset(location,LOC_CONSTANT,OS_ADDR);
location.value:=0;
@ -288,11 +284,28 @@ implementation
(lastlabel<>nil) and
(tai_string(hp1).len=mylength) then
begin
{ if shortstring then check the length byte first and
set the start index to 1 }
case st_type of
st_conststring:
begin
j:=0;
same_string:=true;
if len>0 then
begin
for i:=0 to len-1 do
begin
if tai_string(hp1).str[j]<>value_str[i] then
begin
same_string:=false;
break;
end;
inc(j);
end;
end;
end;
st_shortstring:
begin
{ if shortstring then check the length byte first and
set the start index to 1 }
if len=ord(tai_string(hp1).str[0]) then
begin
j:=1;
@ -311,55 +324,7 @@ implementation
end;
end;
end;
{$ifdef ansistring_bits}
st_ansistring16:
begin
{ before the string the following sequence must be found:
<label>
constsymbol <datalabel>
const32 <len>
const32 <len>
const32 -1
we must then return <label> to reuse
}
hp2:=tai(lastlabelhp.previous);
if assigned(hp2) and
(hp2.typ=ait_const_16bit) and
(tai_const(hp2).value=aword(-1)) and
assigned(hp2.previous) and
(tai(hp2.previous).typ=ait_const_16bit) and
(tai_const(hp2.previous).value=len) and
assigned(hp2.previous.previous) and
(tai(hp2.previous.previous).typ=ait_const_16bit) and
(tai_const(hp2.previous.previous).value=len) and
assigned(hp2.previous.previous.previous) and
(tai(hp2.previous.previous.previous).typ=ait_const_symbol) and
assigned(hp2.previous.previous.previous.previous) and
(tai(hp2.previous.previous.previous.previous).typ=ait_label) then
begin
lastlabel:=tai_label(hp2.previous.previous.previous.previous).l;
same_string:=true;
j:=0;
if len>0 then
begin
for i:=0 to len-1 do
begin
if tai_string(hp1).str[j]<>value_str[i] then
begin
same_string:=false;
break;
end;
inc(j);
end;
end;
end;
end;
{$endif}
{$ifdef ansistring_bits}
st_ansistring32,
{$else}
st_ansistring,
{$endif}
st_widestring :
begin
{ before the string the following sequence must be found:
@ -398,50 +363,6 @@ implementation
end;
end;
end;
{$ifdef ansistring_bits}
st_ansistring64:
begin
{ before the string the following sequence must be found:
<label>
constsymbol <datalabel>
const32 <len>
const32 <len>
const32 -1
we must then return <label> to reuse
}
hp2:=tai(lastlabelhp.previous);
if assigned(hp2) and
(hp2.typ=ait_const_64bit) and
(tai_const(hp2).value=aword(-1)) and
assigned(hp2.previous) and
(tai(hp2.previous).typ=ait_const_64bit) and
(tai_const(hp2.previous).value=len) and
assigned(hp2.previous.previous) and
(tai(hp2.previous.previous).typ=ait_const_64bit) and
(tai_const(hp2.previous.previous).value=len) and
assigned(hp2.previous.previous.previous) and
(tai(hp2.previous.previous.previous).typ=ait_const_symbol) and
assigned(hp2.previous.previous.previous.previous) and
(tai(hp2.previous.previous.previous.previous).typ=ait_label) then
begin
lastlabel:=tai_label(hp2.previous.previous.previous.previous).l;
same_string:=true;
j:=0;
if len>0 then
begin
for i:=0 to len-1 do
begin
if tai_string(hp1).str[j]<>value_str[i] then
begin
same_string:=false;
break;
end;
inc(j);
end;
end;
end;
end;
{$endif}
end;
{ found ? }
if same_string then
@ -465,33 +386,7 @@ implementation
asmlist[al_typedconsts].concat(Tai_label.Create(lastlabel));
{ generate an ansi string ? }
case st_type of
{$ifdef ansistring_bits}
st_ansistring16:
begin
{ an empty ansi string is nil! }
if len=0 then
asmlist[al_typedconsts].concat(Tai_const.Create_ptr(0))
else
begin
objectlibrary.getdatalabel(l1);
objectlibrary.getdatalabel(l2);
Consts.concat(Tai_label.Create(l2));
Consts.concat(Tai_const_symbol.Create(l1));
Consts.concat(Tai_const.Create_32bit(-1));
Consts.concat(Tai_const.Create_32bit(len));
Consts.concat(Tai_label.Create(l1));
getmem(pc,len+2);
move(value_str^,pc^,len);
pc[len]:=#0;
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
asmlist[al_typedconsts].concat(Tai_string.Create_length_pchar(pc,len+1));
{ return the offset of the real string }
lab_str:=l2;
end;
end;
{$endif}
{$ifdef ansistring_bits}st_ansistring32:{$else}st_ansistring:{$endif}
st_ansistring:
begin
{ an empty ansi string is nil! }
if len=0 then
@ -505,42 +400,15 @@ implementation
asmlist[al_typedconsts].concat(Tai_const.Create_aint(-1));
asmlist[al_typedconsts].concat(Tai_const.Create_aint(len));
asmlist[al_typedconsts].concat(Tai_label.Create(l1));
getmem(pc,len+2);
{ include also terminating zero }
getmem(pc,len+1);
move(value_str^,pc^,len);
pc[len]:=#0;
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
asmlist[al_typedconsts].concat(Tai_string.Create_length_pchar(pc,len+1));
asmlist[al_typedconsts].concat(Tai_string.Create_pchar(pc,len+1));
{ return the offset of the real string }
lab_str:=l2;
end;
end;
{$ifdef ansistring_bits}
st_ansistring64:
begin
{ an empty ansi string is nil! }
if len=0 then
Consts.concat(Tai_const.Create_ptr(0))
else
begin
objectlibrary.getdatalabel(l1);
objectlibrary.getdatalabel(l2);
asmlist[al_typedconsts].concat(Tai_label.Create(l2));
asmlist[al_typedconsts].concat(Tai_const_symbol.Create(l1));
asmlist[al_typedconsts].concat(Tai_const.Create_32bit(-1));
asmlist[al_typedconsts].concat(Tai_const.Create_32bit(len));
asmlist[al_typedconsts].concat(Tai_label.Create(l1));
getmem(pc,len+2);
move(value_str^,pc^,len);
pc[len]:=#0;
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
asmlist[al_typedconsts].concat(Tai_string.Create_length_pchar(pc,len+1));
{ return the offset of the real string }
lab_str:=l2;
end;
end;
{$endif}
st_widestring:
begin
{ an empty wide string is nil! }
@ -574,14 +442,20 @@ implementation
l:=255
else
l:=len;
{ also length and terminating zero }
getmem(pc,l+3);
move(value_str^,pc[1],l+1);
{ include length and terminating zero for quick conversion to pchar }
getmem(pc,l+2);
move(value_str^,pc[1],l);
pc[0]:=chr(l);
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
pc[l+1]:=#0;
asmlist[al_typedconsts].concat(Tai_string.Create_length_pchar(pc,l+2));
asmlist[al_typedconsts].concat(Tai_string.Create_pchar(pc,l+2));
end;
st_conststring:
begin
{ include terminating zero }
getmem(pc,len+1);
move(value_str^,pc[0],len);
pc[len]:=#0;
asmlist[al_typedconsts].concat(Tai_string.Create_pchar(pc,len+1));
end;
end;
end;

135
compiler/ncnv.pas
View File

@ -65,6 +65,7 @@ interface
function resulttype_real_to_currency : tnode;
function resulttype_cchar_to_pchar : tnode;
function resulttype_cstring_to_pchar : tnode;
function resulttype_cstring_to_int : tnode;
function resulttype_char_to_char : tnode;
function resulttype_arrayconstructor_to_set : tnode;
function resulttype_pchar_to_string : tnode;
@ -83,6 +84,7 @@ interface
protected
function first_int_to_int : tnode;virtual;
function first_cstring_to_pchar : tnode;virtual;
function first_cstring_to_int : tnode;virtual;
function first_string_to_chararray : tnode;virtual;
function first_char_to_string : tnode;virtual;
function first_nothing : tnode;virtual;
@ -108,6 +110,7 @@ interface
{ any effect }
function _first_int_to_int : tnode;
function _first_cstring_to_pchar : tnode;
function _first_cstring_to_int : tnode;
function _first_string_to_chararray : tnode;
function _first_char_to_string : tnode;
function _first_nothing : tnode;
@ -130,6 +133,7 @@ interface
procedure _second_int_to_int;virtual;
procedure _second_string_to_string;virtual;
procedure _second_cstring_to_pchar;virtual;
procedure _second_cstring_to_int;virtual;
procedure _second_string_to_chararray;virtual;
procedure _second_array_to_pointer;virtual;
procedure _second_pointer_to_array;virtual;
@ -151,6 +155,7 @@ interface
procedure second_int_to_int;virtual;abstract;
procedure second_string_to_string;virtual;abstract;
procedure second_cstring_to_pchar;virtual;abstract;
procedure second_cstring_to_int;virtual;abstract;
procedure second_string_to_chararray;virtual;abstract;
procedure second_array_to_pointer;virtual;abstract;
procedure second_pointer_to_array;virtual;abstract;
@ -610,6 +615,7 @@ implementation
'tc_pchar_2_string',
'tc_cchar_2_pchar',
'tc_cstring_2_pchar',
'tc_cstring_2_int',
'tc_ansistring_2_pchar',
'tc_string_2_chararray',
'tc_chararray_2_string',
@ -700,20 +706,25 @@ implementation
arrsize : aint;
chartype : string[8];
begin
with tarraydef(resulttype.def) do
result := nil;
with tarraydef(resulttype.def) do
begin
if highrange<lowrange then
internalerror(200501051);
arrsize := highrange-lowrange+1;
end;
if (left.nodetype = stringconstn) and
{ left.length+1 since there's always a terminating #0 character (JM) }
(tstringconstnode(left).len+1 >= arrsize) and
(tstringdef(left.resulttype.def).string_typ=st_shortstring) then
if (left.nodetype = stringconstn) and
(tstringdef(left.resulttype.def).string_typ=st_conststring) then
begin
{ handled separately }
result := nil;
exit;
{ if the array is large enough we can use the string
constant directly. This is handled in ncgcnv }
if arrsize>=tstringconstnode(left).len then
exit;
{ Convert to shortstring/ansistring and call helper }
if tstringconstnode(left).len>255 then
inserttypeconv(left,cansistringtype)
else
inserttypeconv(left,cshortstringtype);
end;
if is_widechar(tarraydef(resulttype.def).elementtype.def) then
chartype:='widechar'
@ -732,47 +743,12 @@ implementation
var
procname: string[31];
stringpara : tcallparanode;
pw : pcompilerwidestring;
pc : pchar;
begin
result:=nil;
if left.nodetype=stringconstn then
begin
{ convert ascii 2 unicode }
{$ifdef ansistring_bits}
if (tstringdef(resulttype.def).string_typ=st_widestring) and
(tstringconstnode(left).st_type in [st_ansistring16,st_ansistring32,
st_ansistring64,st_shortstring,st_longstring]) then
{$else}
if (tstringdef(resulttype.def).string_typ=st_widestring) and
(tstringconstnode(left).st_type in [st_ansistring,st_shortstring,st_longstring]) then
{$endif}
begin
initwidestring(pw);
ascii2unicode(tstringconstnode(left).value_str,tstringconstnode(left).len,pw);
ansistringdispose(tstringconstnode(left).value_str,tstringconstnode(left).len);
pcompilerwidestring(tstringconstnode(left).value_str):=pw;
end
else
{ convert unicode 2 ascii }
{$ifdef ansistring_bits}
if (tstringconstnode(left).st_type=st_widestring) and
(tstringdef(resulttype.def).string_typ in [st_ansistring16,st_ansistring32,
st_ansistring64,st_shortstring,st_longstring]) then
{$else}
if (tstringconstnode(left).st_type=st_widestring) and
(tstringdef(resulttype.def).string_typ in [st_ansistring,st_shortstring,st_longstring]) then
{$endif}
begin
pw:=pcompilerwidestring(tstringconstnode(left).value_str);
getmem(pc,getlengthwidestring(pw)+1);
unicode2ascii(pw,pc);
donewidestring(pw);
tstringconstnode(left).value_str:=pc;
end;
tstringconstnode(left).st_type:=tstringdef(resulttype.def).string_typ;
tstringconstnode(left).resulttype:=resulttype;
tstringconstnode(left).changestringtype(resulttype);
result:=left;
left:=nil;
end
@ -1053,6 +1029,25 @@ implementation
end;
function ttypeconvnode.resulttype_cstring_to_int : tnode;
var
fcc : cardinal;
pb : pbyte;
begin
result:=nil;
if left.nodetype<>stringconstn then
internalerror(200510012);
if tstringconstnode(left).len=4 then
begin
pb:=pbyte(tstringconstnode(left).value_str);
fcc:=(pb[0] shl 24) or (pb[1] shl 16) or (pb[2] shl 8) or pb[3];
result:=cordconstnode.create(fcc,u32inttype,false);
end
else
CGMessage2(type_e_illegal_type_conversion,left.resulttype.def.gettypename,resulttype.def.gettypename);
end;
function ttypeconvnode.resulttype_arrayconstructor_to_set : tnode;
var
@ -1292,7 +1287,6 @@ implementation
function ttypeconvnode.resulttype_call_helper(c : tconverttype) : tnode;
{$ifdef fpc}
const
resulttypeconvert : array[tconverttype] of pointer = (
{none} nil,
@ -1304,6 +1298,7 @@ implementation
{ pchar_2_string } @ttypeconvnode.resulttype_pchar_to_string,
{ cchar_2_pchar } @ttypeconvnode.resulttype_cchar_to_pchar,
{ cstring_2_pchar } @ttypeconvnode.resulttype_cstring_to_pchar,
{ cstring_2_int } @ttypeconvnode.resulttype_cstring_to_int,
{ ansistring_2_pchar } nil,
{ string_2_chararray } @ttypeconvnode.resulttype_string_to_chararray,
{ chararray_2_string } @ttypeconvnode.resulttype_chararray_to_string,
@ -1351,38 +1346,13 @@ implementation
if assigned(r.proc) then
result:=tprocedureofobject(r)();
end;
{$else}
begin
case c of
tc_string_2_string: resulttype_string_to_string;
tc_char_2_string : resulttype_char_to_string;
tc_char_2_chararray: resulttype_char_to_chararray;
tc_pchar_2_string : resulttype_pchar_to_string;
tc_cchar_2_pchar : resulttype_cchar_to_pchar;
tc_cstring_2_pchar : resulttype_cstring_to_pchar;
tc_string_2_chararray : resulttype_string_to_chararray;
tc_chararray_2_string : resulttype_chararray_to_string;
tc_real_2_real : resulttype_real_to_real;
tc_int_2_real : resulttype_int_to_real;
tc_real_2_currency : resulttype_real_to_currency;
tc_arrayconstructor_2_set : resulttype_arrayconstructor_to_set;
tc_cord_2_pointer : resulttype_cord_to_pointer;
tc_intf_2_guid : resulttype_interface_to_guid;
tc_char_2_char : resulttype_char_to_char;
tc_dynarray_2_openarray : resulttype_dynarray_to_openarray;
tc_pwchar_2_string : resulttype_pwchar_to_string;
tc_variant_2_dynarray : resulttype_variant_to_dynarray;
tc_dynarray_2_variant : resulttype_dynarray_to_variant;
end;
end;
{$Endif fpc}
function ttypeconvnode.det_resulttype:tnode;
var
htype : ttype;
hp,hp2 : tnode;
hp : tnode;
currprocdef : tabstractprocdef;
aprocdef : tprocdef;
eq : tequaltype;
@ -1775,12 +1745,20 @@ implementation
function ttypeconvnode.first_cstring_to_pchar : tnode;
begin
first_cstring_to_pchar:=nil;
result:=nil;
registersint:=1;
expectloc:=LOC_REGISTER;
end;
function ttypeconvnode.first_cstring_to_int : tnode;
begin
result:=nil;
internalerror(200510014);
end;
function ttypeconvnode.first_string_to_chararray : tnode;
begin
@ -2058,6 +2036,11 @@ implementation
result:=first_cstring_to_pchar;
end;
function ttypeconvnode._first_cstring_to_int : tnode;
begin
result:=first_cstring_to_int;
end;
function ttypeconvnode._first_string_to_chararray : tnode;
begin
result:=first_string_to_chararray;
@ -2161,6 +2144,7 @@ implementation
nil, { removed in resulttype_chararray_to_string }
@ttypeconvnode._first_cchar_to_pchar,
@ttypeconvnode._first_cstring_to_pchar,
@ttypeconvnode._first_cstring_to_int,
@ttypeconvnode._first_ansistring_to_pchar,
@ttypeconvnode._first_string_to_chararray,
nil, { removed in resulttype_chararray_to_string }
@ -2285,6 +2269,12 @@ implementation
end;
procedure ttypeconvnode._second_cstring_to_int;
begin
second_cstring_to_int;
end;
procedure ttypeconvnode._second_string_to_chararray;
begin
second_string_to_chararray;
@ -2398,6 +2388,7 @@ implementation
@ttypeconvnode._second_nothing, { pchar_to_string, handled in resulttype pass }
@ttypeconvnode._second_nothing, {cchar_to_pchar}
@ttypeconvnode._second_cstring_to_pchar,
@ttypeconvnode._second_cstring_to_int,
@ttypeconvnode._second_ansistring_to_pchar,
@ttypeconvnode._second_string_to_chararray,
@ttypeconvnode._second_nothing, { chararray_to_string, handled in resulttype pass }

110
compiler/ncon.pas
View File

@ -91,7 +91,7 @@ interface
lab_str : tasmlabel;
st_type : tstringtype;
constructor createstr(const s : string;st:tstringtype);virtual;
constructor createpchar(s : pchar;l : longint);virtual;
constructor createpchar(s : pchar;l : longint;st:tstringtype);virtual;
constructor createwstr(w : pcompilerwidestring);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
@ -103,6 +103,7 @@ interface
function det_resulttype:tnode;override;
function getpcharcopy : pchar;
function docompare(p: tnode) : boolean; override;
procedure changestringtype(const newtype:ttype);
end;
tstringconstnodeclass = class of tstringconstnode;
@ -237,12 +238,10 @@ implementation
conststring :
begin
len:=p.value.len;
if not(cs_ansistrings in aktlocalswitches) and (len>255) then
len:=255;
getmem(pc,len+1);
move(pchar(p.value.valueptr)^,pc^,len);
pc[len]:=#0;
p1:=cstringconstnode.createpchar(pc,len);
p1:=cstringconstnode.createpchar(pc,len,st_conststring);
end;
constreal :
p1:=crealconstnode.create(pbestreal(p.value.valueptr)^,pbestrealtype^);
@ -520,10 +519,8 @@ implementation
*****************************************************************************}
constructor tstringconstnode.createstr(const s : string;st:tstringtype);
var
l : longint;
begin
inherited create(stringconstn);
l:=length(s);
@ -533,30 +530,11 @@ implementation
move(s[1],value_str^,l);
value_str[l]:=#0;
lab_str:=nil;
if st=st_default then
begin
if cs_ansistrings in aktlocalswitches then
{$ifdef ansistring_bits}
case aktansistring_bits of
sb_16:
st_type:=st_ansistring16;
sb_32:
st_type:=st_ansistring32;
sb_64:
st_type:=st_ansistring64;
end
{$else}
st_type:=st_ansistring
{$endif}
else
st_type:=st_shortstring;
end
else
st_type:=st;
st_type:=st;
end;
constructor tstringconstnode.createwstr(w : pcompilerwidestring);
constructor tstringconstnode.createwstr(w : pcompilerwidestring);
begin
inherited create(stringconstn);
len:=getlengthwidestring(w);
@ -566,28 +544,13 @@ implementation
st_type:=st_widestring;
end;
constructor tstringconstnode.createpchar(s : pchar;l : longint);
constructor tstringconstnode.createpchar(s : pchar;l : longint;st:tstringtype);
begin
inherited create(stringconstn);
len:=l;
value_str:=s;
if (cs_ansistrings in aktlocalswitches) or
(len>255) then
{$ifdef ansistring_bits}
case aktansistring_bits of
sb_16:
st_type:=st_ansistring16;
sb_32:
st_type:=st_ansistring32;
sb_64:
st_type:=st_ansistring64;
end
{$else}
st_type:=st_ansistring
{$endif}
else
st_type:=st_shortstring;
st_type:=st;
lab_str:=nil;
end;
@ -673,22 +636,25 @@ implementation
end;
function tstringconstnode.det_resulttype:tnode;
var
l : aint;
begin
result:=nil;
case st_type of
st_conststring :
begin
{ handle and store as array[0..len-1] of char }
if len>0 then
l:=len-1
else
l:=0;
resulttype.setdef(tarraydef.create(0,l,s32inttype));
tarraydef(resulttype.def).setelementtype(cchartype);
end;
st_shortstring :
resulttype:=cshortstringtype;
{$ifdef ansistring_bits}
st_ansistring16:
resulttype:=cansistringtype16;
st_ansistring32:
resulttype:=cansistringtype32;
st_ansistring64:
resulttype:=cansistringtype64;
{$else}
st_ansistring :
resulttype:=cansistringtype;
{$endif}
st_widestring :
resulttype:=cwidestringtype;
st_longstring :
@ -699,17 +665,14 @@ implementation
function tstringconstnode.pass_1 : tnode;
begin
result:=nil;
{$ifdef ansistring_bits}
if (st_type in [st_ansistring16,st_ansistring32,st_ansistring64,st_widestring]) and
{$else}
if (st_type in [st_ansistring,st_widestring]) and
{$endif}
(len=0) then
expectloc:=LOC_CONSTANT
else
expectloc:=LOC_CREFERENCE;
end;
function tstringconstnode.getpcharcopy : pchar;
var
pc : pchar;
@ -733,6 +696,39 @@ implementation
(lab_str = tstringconstnode(p).lab_str);
end;
procedure tstringconstnode.changestringtype(const newtype:ttype);
var
pw : pcompilerwidestring;
pc : pchar;
begin
if newtype.def.deftype<>stringdef then
internalerror(200510011);
{ convert ascii 2 unicode }
if (tstringdef(newtype.def).string_typ=st_widestring) and
(st_type<>st_widestring) then
begin
initwidestring(pw);
ascii2unicode(value_str,len,pw);
ansistringdispose(value_str,len);
pcompilerwidestring(value_str):=pw;
end
else
{ convert unicode 2 ascii }
if (st_type=st_widestring) and
(tstringdef(newtype.def).string_typ<>st_widestring) then
begin
pw:=pcompilerwidestring(value_str);
getmem(pc,getlengthwidestring(pw)+1);
unicode2ascii(pw,pc);
donewidestring(pw);
value_str:=pc;
end;
st_type:=tstringdef(newtype.def).string_typ;
resulttype:=newtype;
end;
{*****************************************************************************
TSETCONSTNODE
*****************************************************************************}

2
compiler/nobj.pas
View File

@ -269,7 +269,7 @@ implementation
asmlist[al_globals].concat(tai_const.create_8bit(len));
getmem(ca,len+1);
move(p^.data.messageinf.str^,ca^,len+1);
asmlist[al_globals].concat(Tai_string.Create_pchar(ca));
asmlist[al_globals].concat(Tai_string.Create_pchar(ca,len));
if assigned(p^.r) then
writenames(p^.r);
end;

24
compiler/pexpr.pas
View File

@ -674,18 +674,24 @@ implementation
begin
consume(_LKLAMMER);
in_args:=true;
{ Translate to x:=x+y[+z]. The addnode will do the
type checking }
p2:=nil;
repeat
p1:=comp_expr(true);
set_varstate(p1,vs_used,[vsf_must_be_valid]);
if not((p1.resulttype.def.deftype=stringdef) or
((p1.resulttype.def.deftype=orddef) and
(torddef(p1.resulttype.def).typ=uchar))) then
Message(parser_e_illegal_parameter_list);
if p2<>nil then
p2:=caddnode.create(addn,p2,p1)
else
p2:=p1;
begin
{ Force string type if it isn't yet }
if not(
(p1.resulttype.def.deftype=stringdef) or
is_chararray(p1.resulttype.def) or
is_char(p1.resulttype.def)
) then
inserttypeconv(p1,cshortstringtype);
p2:=p1;
end;
until not try_to_consume(_COMMA);
consume(_RKLAMMER);
statement_syssym:=p2;
@ -779,7 +785,7 @@ implementation
else
begin
{ then insert an empty string }
p2:=cstringconstnode.createstr('',st_default);
p2:=cstringconstnode.createstr('',st_conststring);
end;
statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,nil)));
consume(_RKLAMMER);
@ -1387,7 +1393,7 @@ implementation
getmem(pc,len+1);
move(pchar(tconstsym(srsym).value.valueptr)^,pc^,len);
pc[len]:=#0;
p1:=cstringconstnode.createpchar(pc,len);
p1:=cstringconstnode.createpchar(pc,len,st_conststring);
end;
constwstring :
p1:=cstringconstnode.createwstr(pcompilerwidestring(tconstsym(srsym).value.valueptr));
@ -2214,7 +2220,7 @@ implementation
_CSTRING :
begin
p1:=cstringconstnode.createstr(pattern,st_default);
p1:=cstringconstnode.createstr(pattern,st_conststring);
consume(_CSTRING);
end;

13
compiler/ptconst.pas
View File

@ -353,7 +353,7 @@ implementation
len:=255;
getmem(ca,len+2);
move(tstringconstnode(p).value_str^,ca^,len+1);
asmlist[al_const].concat(Tai_string.Create_length_pchar(ca,len+1));
asmlist[al_const].concat(Tai_string.Create_pchar(ca,len+1));
end
else
if is_constcharnode(p) then
@ -593,7 +593,7 @@ implementation
getmem(ca,strlength+1);
move(strval^,ca^,strlength);
ca[strlength]:=#0;
asmlist[cural].concat(Tai_string.Create_length_pchar(ca,strlength));
asmlist[cural].concat(Tai_string.Create_pchar(ca,strlength));
{ fillup with spaces if size is shorter }
if t.def.size>strlength then
begin
@ -603,7 +603,7 @@ implementation
fillchar(ca[0],t.def.size-strlength-1,' ');
ca[t.def.size-strlength-1]:=#0;
{ this can also handle longer strings }
asmlist[cural].concat(Tai_string.Create_length_pchar(ca,t.def.size-strlength-1));
asmlist[cural].concat(Tai_string.Create_pchar(ca,t.def.size-strlength-1));
end;
end;
st_ansistring:
@ -619,14 +619,11 @@ implementation
asmlist[al_const].concat(Tai_const.Create_aint(-1));
asmlist[al_const].concat(Tai_const.Create_aint(strlength));
asmlist[al_const].concat(Tai_label.Create(ll));
getmem(ca,strlength+2);
getmem(ca,strlength+1);
move(strval^,ca^,strlength);
{ The terminating #0 to be stored in the .data section (JM) }
ca[strlength]:=#0;
{ End of the PChar. The memory has to be allocated because in }
{ tai_string.done, there is a freemem(len+1) (JM) }
ca[strlength+1]:=#0;
asmlist[al_const].concat(Tai_string.Create_length_pchar(ca,strlength+1));
asmlist[al_const].concat(Tai_string.Create_pchar(ca,strlength));
end;
end;
st_widestring:

2
compiler/rautils.pas
View File

@ -1415,7 +1415,7 @@ end;
pc: PChar;
Begin
getmem(pc,length(s)+1);
p.concat(Tai_string.Create_length_pchar(strpcopy(pc,s),length(s)));
p.concat(Tai_string.Create_pchar(strpcopy(pc,s),length(s)));
end;
Procedure ConcatPasString(p : TAAsmoutput;s:string);

9
compiler/symconst.pas
View File

@ -188,16 +188,11 @@ type
);
{ string types }
tstringtype = (st_default,
tstringtype = (
st_conststring,
st_shortstring,
st_longstring,
{$ifndef ansistring_bits}
st_ansistring,
{$else}
st_ansistring16,
st_ansistring32,
st_ansistring64,
{$endif}
st_widestring
);

6
tests/tbs/tb0429.pp
View File

@ -10,11 +10,11 @@ end;
procedure lowercase(c:shortstring);overload;
begin
writeln('short');
err:=false;
end;
procedure lowercase(c:ansistring);overload;
begin
writeln('ansi');
err:=false;
end;
var
@ -23,7 +23,9 @@ var
i : longint;
begin
err:=true;
{ this should choosse the shortstring version }
{ this should choosse the ansistring version }
w:='';
for i:=1 to 300 do w:=w+'.';
lowercase(w);
if err then
begin

2
tests/test/tmacpas2.pp
View File

@ -23,7 +23,7 @@ end;
procedure TestFourCharCode(myFCC: MyFourCharCodeType);
begin
Writeln('FPC creator code as number: ', myFCC);
Writeln('FPC creator code as number: ', hexstr(myFCC,8));
if myFCC <> $46506173 then
success := false;
end;

23
tests/webtbs/tw4390.pp Normal file
View File

@ -0,0 +1,23 @@
{ Source provided for Free Pascal Bug Report 4390 }
{ Submitted by "Benjamin Rosseaux" on 2005-09-28 }
{ e-mail: benjamin@0ok.de }
PROGRAM Test;
{$APPTYPE CONSOLE}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
PROCEDURE WriteToFile(CONST Buf;Size:INTEGER);
var
s : shortstring;
BEGIN
move(Buf,s[1],size);
s[0]:=chr(size);
writeln('Writing: "',s,'"');
if s<>'TEST' then
halt(1);
END;
BEGIN
WriteToFile('TEST',4);
END.