* support string constants > 255 chars

* don't cut off anymore string constants silently at 255 chars

git-svn-id: trunk@14789 -
This commit is contained in:
florian 2010-01-24 09:28:46 +00:00
parent fe6a0d27a1
commit c6ffbe9eda
19 changed files with 503 additions and 424 deletions

5
.gitattributes vendored
View File

@ -7595,7 +7595,6 @@ tests/tbf/tb0109.pp svneol=native#text/plain
tests/tbf/tb0110.pp svneol=native#text/plain
tests/tbf/tb0111.pp svneol=native#text/plain
tests/tbf/tb0112.pp svneol=native#text/plain
tests/tbf/tb0113.pp svneol=native#text/plain
tests/tbf/tb0114.pp svneol=native#text/plain
tests/tbf/tb0115.pp svneol=native#text/plain
tests/tbf/tb0116.pp svneol=native#text/plain
@ -7712,6 +7711,7 @@ tests/tbf/tb0215d.pp svneol=native#text/plain
tests/tbf/tb0215e.pp svneol=native#text/plain
tests/tbf/tb0216.pp svneol=native#text/plain
tests/tbf/tb0217.pp svneol=native#text/plain
tests/tbf/tb0218.pp svneol=native#text/plain
tests/tbf/ub0115.pp svneol=native#text/plain
tests/tbf/ub0149.pp svneol=native#text/plain
tests/tbf/ub0158a.pp svneol=native#text/plain
@ -8274,6 +8274,7 @@ tests/tbs/tb0564.pp svneol=native#text/plain
tests/tbs/tb0565.pp svneol=native#text/plain
tests/tbs/tb0566.pp svneol=native#text/plain
tests/tbs/tb0567.pp svneol=native#text/plain
tests/tbs/tb0568.pp svneol=native#text/plain
tests/tbs/tb205.pp svneol=native#text/plain
tests/tbs/ub0060.pp svneol=native#text/plain
tests/tbs/ub0069.pp svneol=native#text/plain
@ -8913,6 +8914,8 @@ tests/test/tclassinfo1.pp svneol=native#text/pascal
tests/test/tclrprop.pp svneol=native#text/plain
tests/test/tcmp.pp svneol=native#text/plain
tests/test/tcmp0.pp svneol=native#text/plain
tests/test/tcstring1.pp svneol=native#text/pascal
tests/test/tcstring2.pp svneol=native#text/pascal
tests/test/tdel1.pp svneol=native#text/plain
tests/test/tdispinterface1a.pp svneol=native#text/pascal
tests/test/tdispinterface1b.pp svneol=native#text/pascal

View File

@ -1288,6 +1288,9 @@ parser_e_operator_not_overloaded_3=03284_E_Operator is not overloaded: "$1" $2 "
% this type.
parser_e_more_array_elements_expected=03285_E_Expected another $1 array elements
% When declaring a typed constant array, you provided to few elements to initialize the array
parser_e_string_const_too_long=03286_E_String constant too long while ansistrings are disabled
% Only when a piece of code is compiled with ansistrings enabled (\var{\{\$H+\}}), string constants
% longer than 255 characters are allowed.
% \end{description}
#
# Type Checking

View File

@ -373,6 +373,7 @@ const
parser_e_operator_not_overloaded_2=03283;
parser_e_operator_not_overloaded_3=03284;
parser_e_more_array_elements_expected=03285;
parser_e_string_const_too_long=03286;
type_e_mismatch=04000;
type_e_incompatible_types=04001;
type_e_not_equal_types=04002;
@ -850,9 +851,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 55693;
MsgTxtSize = 55757;
MsgIdxMax : array[1..20] of longint=(
24,87,286,95,80,51,110,22,202,63,
24,87,287,95,80,51,110,22,202,63,
49,20,1,1,1,1,1,1,1,1
);

File diff suppressed because it is too large Load Diff

View File

@ -300,7 +300,10 @@ implementation
begin
len:=p.value.len;
if not(cs_ansistrings in current_settings.localswitches) and (len>255) then
len:=255;
begin
message(parser_e_string_const_too_long);
len:=255;
end;
getmem(pc,len+1);
move(pchar(p.value.valueptr)^,pc^,len);
pc[len]:=#0;

View File

@ -85,6 +85,7 @@ implementation
c:=#0;
pattern:='';
orgpattern:='';
cstringpattern:='';
current_scanner:=nil;
switchesstatestackpos:=0;
@ -211,16 +212,16 @@ implementation
_CSTRING :
begin
i:=0;
while (i<length(pattern)) do
while (i<length(cstringpattern)) do
begin
inc(i);
if pattern[i]='''' then
if cstringpattern[i]='''' then
begin
insert('''',pattern,i);
insert('''',cstringpattern,i);
inc(i);
end;
end;
preprocfile^.Add(''''+pattern+'''');
preprocfile^.Add(''''+cstringpattern+'''');
end;
_CCHAR :
begin

View File

@ -327,7 +327,10 @@ implementation
begin
if deprecatedmsg<>nil then
internalerror(200910181);
deprecatedmsg:=stringdup(pattern);
if token=_CSTRING then
deprecatedmsg:=stringdup(cstringpattern)
else
deprecatedmsg:=stringdup(pattern);
consume(token);
include(symopt,sp_has_deprecated_msg);
end;

View File

@ -599,7 +599,7 @@ implementation
if (idtoken=_LOCATION) then
begin
consume(_LOCATION);
locationstr:=pattern;
locationstr:=cstringpattern;
consume(_CSTRING);
end
else
@ -1036,7 +1036,7 @@ implementation
if po_explicitparaloc in pd.procoptions then
begin
consume(_LOCATION);
locationstr:=pattern;
locationstr:=cstringpattern;
consume(_CSTRING);
end
else
@ -1276,11 +1276,16 @@ procedure pd_asmname(pd:tabstractprocdef);
begin
if pd.typ<>procdef then
internalerror(200304267);
tprocdef(pd).aliasnames.insert(target_info.Cprefix+pattern);
if token=_CCHAR then
consume(_CCHAR)
begin
tprocdef(pd).aliasnames.insert(target_info.Cprefix+pattern);
consume(_CCHAR)
end
else
consume(_CSTRING);
begin
tprocdef(pd).aliasnames.insert(target_info.Cprefix+cstringpattern);
consume(_CSTRING);
end;
{ we don't need anything else }
tprocdef(pd).forwarddef:=false;
end;

View File

@ -162,11 +162,9 @@ implementation
begin
pt:=comp_expr(true);
if pt.nodetype=stringconstn then
hpname:=strpas(tstringconstnode(pt).value_str)
hpname:=strpas(tstringconstnode(pt).value_str)
else
begin
consume(_CSTRING);
end;
consume(_CSTRING);
options:=options or eo_name;
pt.free;
DefString:=hpname+'='+InternalProcName;

View File

@ -2508,7 +2508,7 @@ implementation
_CSTRING :
begin
p1:=cstringconstnode.createstr(pattern);
p1:=cstringconstnode.createpchar(ansistring2pchar(cstringpattern),length(cstringpattern));
consume(_CSTRING);
end;

View File

@ -990,7 +990,10 @@ implementation
begin
if deprecatedmsg<>nil then
internalerror(201001221);
deprecatedmsg:=stringdup(pattern);
if token=_CSTRING then
deprecatedmsg:=stringdup(cstringpattern)
else
deprecatedmsg:=stringdup(pattern);
consume(token);
include(moduleopt,mo_has_deprecated_msg);
end;

View File

@ -218,13 +218,13 @@ implementation
casenode.addlabel(blockid,hl1,hl2);
end
else
begin
begin
{ type check for string case statements }
if (caseofstring and (not is_conststring_or_constcharnode(p))) or
{ type checking for ordinal case statements }
((not caseofstring) and (not is_subequal(casedef, p.resultdef))) then
CGMessage(parser_e_case_mismatch);
if caseofstring then
begin
sl1:=get_string_value(p, tstringdef(casedef));
@ -474,7 +474,7 @@ implementation
result:=cfornode.create(hloopvar,hfrom,hto,hblock,backward);
end;
function for_in_loop_create(hloopvar: tnode): tnode;
var
expr: tnode;
@ -487,7 +487,7 @@ implementation
set_varstate(hloopvar,vs_read,[vsf_must_be_valid]);
result := create_for_in_loop(hloopvar, statement, expr);
expr.free;
end;
@ -975,7 +975,7 @@ implementation
Message(parser_w_register_list_ignored);
repeat
{ it's possible to specify the modified registers }
reg:=std_regnum_search(lower(pattern));
reg:=std_regnum_search(lower(cstringpattern));
if reg<>NR_NO then
begin
if (getregtype(reg)=R_INTREGISTER) and not(po_assembler in current_procinfo.procdef.procoptions) then

View File

@ -201,6 +201,7 @@ interface
c : char;
orgpattern,
pattern : string;
cstringpattern : ansistring;
patternw : pcompilerwidestring;
{ token }
@ -2038,6 +2039,7 @@ In case not, the value returned can be arbitrary.
procedure tscannerfile.recordtoken;
var
a : array[0..1] of byte;
len : sizeint;
begin
if not assigned(recordtokenbuf) then
internalerror(200511176);
@ -2088,8 +2090,13 @@ In case not, the value returned can be arbitrary.
recordtokenbuf.write(patternw^.len,sizeof(sizeint));
recordtokenbuf.write(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar));
end;
_CSTRING:
begin
len:=length(cstringpattern);
recordtokenbuf.write(len,sizeof(sizeint));
recordtokenbuf.write(pattern[1],length(pattern));
end;
_CCHAR,
_CSTRING,
_INTCONST,
_REALNUMBER :
begin
@ -2166,10 +2173,19 @@ In case not, the value returned can be arbitrary.
replaytokenbuf.read(wlen,sizeof(SizeInt));
setlengthwidestring(patternw,wlen);
replaytokenbuf.read(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar));
orgpattern:='';
pattern:='';
cstringpattern:='';
end;
_CSTRING:
begin
replaytokenbuf.read(wlen,sizeof(sizeint));
setlength(cstringpattern,wlen);
replaytokenbuf.read(pattern[1],length(pattern));
orgpattern:='';
pattern:='';
end;
_CCHAR,
_CSTRING,
_INTCONST,
_REALNUMBER :
begin
@ -3760,7 +3776,7 @@ In case not, the value returned can be arbitrary.
begin
len:=0;
msgwritten:=false;
pattern:='';
cstringpattern:='';
iswidestring:=false;
if c='^' then
begin
@ -3776,10 +3792,11 @@ In case not, the value returned can be arbitrary.
else
begin
inc(len);
setlength(cstringpattern,256);
if c<#64 then
pattern[len]:=chr(ord(c)+64)
cstringpattern[len]:=chr(ord(c)+64)
else
pattern[len]:=chr(ord(c)-64);
cstringpattern[len]:=chr(ord(c)-64);
readchar;
end;
end;
@ -3838,7 +3855,7 @@ In case not, the value returned can be arbitrary.
begin
if not iswidestring then
begin
ascii2unicode(@pattern[1],len,patternw);
ascii2unicode(@cstringpattern[1],len,patternw);
iswidestring:=true;
len:=0;
end;
@ -3851,19 +3868,10 @@ In case not, the value returned can be arbitrary.
concatwidestringchar(patternw,asciichar2unicode(char(m)))
else
begin
if len<255 then
begin
inc(len);
pattern[len]:=chr(m);
end
else
begin
if not msgwritten then
begin
Message(scan_e_string_exceeds_255_chars);
msgwritten:=true;
end;
end;
if len>=length(cstringpattern) then
setlength(cstringpattern,length(cstringpattern)+256);
inc(len);
cstringpattern[len]:=chr(m);
end;
end;
'''' :
@ -3888,7 +3896,7 @@ In case not, the value returned can be arbitrary.
{ convert existing string to an utf-8 string }
if not iswidestring then
begin
ascii2unicode(@pattern[1],len,patternw);
ascii2unicode(@cstringpattern[1],len,patternw);
iswidestring:=true;
len:=0;
end;
@ -3934,19 +3942,10 @@ In case not, the value returned can be arbitrary.
end
else
begin
if len<255 then
begin
inc(len);
pattern[len]:=c;
end
else
begin
if not msgwritten then
begin
Message(scan_e_string_exceeds_255_chars);
msgwritten:=true;
end;
end;
if len>=length(cstringpattern) then
setlength(cstringpattern,length(cstringpattern)+256);
inc(len);
cstringpattern[len]:=c;
end;
until false;
end;
@ -3963,19 +3962,10 @@ In case not, the value returned can be arbitrary.
concatwidestringchar(patternw,asciichar2unicode(c))
else
begin
if len<255 then
begin
inc(len);
pattern[len]:=c;
end
else
begin
if not msgwritten then
begin
Message(scan_e_string_exceeds_255_chars);
msgwritten:=true;
end;
end;
if len>=length(cstringpattern) then
setlength(cstringpattern,length(cstringpattern)+256);
inc(len);
cstringpattern[len]:=c;
end;
readchar;
@ -3987,17 +3977,20 @@ In case not, the value returned can be arbitrary.
{ strings with length 1 become const chars }
if iswidestring then
begin
if patternw^.len=1 then
if patternw^.len=1 then
token:=_CWCHAR
else
else
token:=_CWSTRING;
end
else
begin
pattern[0]:=chr(len);
if len=1 then
token:=_CCHAR
else
setlength(cstringpattern,len);
if length(cstringpattern)=1 then
begin
token:=_CCHAR;
pattern:=cstringpattern;
end
else
token:=_CSTRING;
end;
goto exit_label;

40
tests/tbf/tb0218.pp Normal file
View File

@ -0,0 +1,40 @@
{ %fail }
{ Old file: tbs0229.pp }
{ consts > 255 are truncated (should work in -S2,-Sd) OK 0.99.11 (PFV) }
{ this is not true anymore because it can lead silently to bugs,
it is allowed now in $H+ mode else it causes an error (FK) }
{$mode objfpc}
{$X-}
const
CRLF = #13#10;
c =
'1-----------------'+CRLF+
'2/PcbDict 200 dict'+CRLF+
'3PcbDicljkljkljk b'+CRLF+
'4PcbDict /DictMaix'+CRLF+
'5% draw a pin-poll'+CRLF+
'6% get x+CRLF+ y s'+CRLF+
'7/thickness exch h'+CRLF+
'8gsave x y transls'+CRLF+
'9---------jljkljkl'+crlf+
'10----------2jkljk'+crlf+
'11----------jkllkk'+crlf+
'eeeeeeeeeeeeeeeeee'+crlf+
'2-----------------'+CRLF+
'2/PcbDict 200 dice'+CRLF+
'END____.XXXXXxjk b'+CRLF+
'4PcbDict /DictMaix'+CRLF+
'5% draw a pin-poll'+CRLF+
'6% get x+CRLF+ y s'+CRLF+
'7/thickness exch h'+CRLF+
'8gsave x y transls'+CRLF+
'9---------jljkljkl'+crlf+
'10----------2jkljk'+crlf+
'11----------jkllkk'+crlf+
'eeeeeeeeeeeeeeeeee12';
begin
write(c);
end.

View File

@ -1,5 +1,9 @@
{ Old file: tbs0229.pp }
{ consts > 255 are truncated (should work in -S2,-Sd) OK 0.99.11 (PFV) }
{ this is not true anymore because it can lead silently to bugs,
it is allowed now in $H+ mode else it causes an error (FK) }
{$H+}
{$mode objfpc}
{$X-}

View File

@ -1,8 +1,9 @@
{ %FAIL }
{ this is allowed now, even in $H- mode because '....' is handled as array in this case (FK) }
var
i : integer;
begin
{ String constants can't exceed 255 chars }
i:=length('12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890');
if i<>280 then
halt(1);
end.

9
tests/test/tcstring1.pp Normal file
View File

@ -0,0 +1,9 @@
{$H+}
const
s = 'asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3';
begin
if length(s)<>1804 then
halt(1);
writeln('ok');
end.

10
tests/test/tcstring2.pp Normal file
View File

@ -0,0 +1,10 @@
{ %fail }
{ this works only when ansistrings are enabled }
const
s = 'asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3asdfvkh4vk347vhjvkh7j3';
begin
if length(s)<>1804 then
halt(1);
writeln('ok');
end.

View File

@ -3,6 +3,9 @@
{ %skiptarget = go32v2,macos }
{ execute this test only on reasonable fast cpus }
{ we do not cut off too long strings silently anymore }
{$H+}
{$ifdef darwin}
{$PIC+}
{$endif darwin}