paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 06:29:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fixed using readstr/writestr inside routines called from the parameter

Browse Source 
list of another readstr/writestr expression (mantis #23912)

git-svn-id: trunk@23888 -
This commit is contained in:
Jonas Maebe 2013-03-17 14:23:33 +00:00
parent 784641ec46
commit e1e11f81e3
6 changed files with 182 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -13275,6 +13275,7 @@ tests/webtbs/tw2378.pp svneol=native#text/plain
tests/webtbs/tw23819.pp -text svneol=native#text/plain
tests/webtbs/tw2382.pp svneol=native#text/plain
tests/webtbs/tw2388.pp svneol=native#text/plain
tests/webtbs/tw23912.pp -text svneol=native#text/plain
tests/webtbs/tw23962.pp svneol=native#text/plain
tests/webtbs/tw2397.pp svneol=native#text/plain
tests/webtbs/tw24007.pp svneol=native#text/plain

63
compiler/ninl.pas
View File

@ -1171,9 +1171,34 @@ implementation
{ make inserting of additional statements easier }
newblock:=internalstatements(newstatement);
if is_rwstr then
begin
{ create a dummy temp text file that will be used to cache the
readstr/writestr state. Can't use a global variable in the system
unit because these can be nested (in case of parameters to
writestr that are function calls to functions that also call
readstr/writestr) }
textsym:=search_system_type('TEXT');
filetemp:=ctempcreatenode.create(textsym.typedef,textsym.typedef.size,tt_persistent,false);
addstatement(newstatement,filetemp);
if (do_read) then
name:='fpc_setupreadstr_'
else
name:='fpc_setupwritestr_';
name:=name+tstringdef(filepara.resultdef).stringtypname;
{ remove the source/destination string parameter from the }
{ parameter chain }
left:=filepara.right;
filepara.right:=ccallparanode.create(ctemprefnode.create(filetemp),nil);
{ pass the temp text file and the source/destination string to the
setup routine, which will store the string's address in the
textrec }
addstatement(newstatement,ccallnode.createintern(name,filepara));
filepara:=ccallparanode.create(ctemprefnode.create(filetemp),nil);
end
{ if we don't have a filepara, create one containing the default }
if not assigned(filepara) or
is_rwstr then
else if not assigned(filepara) then
begin
{ since the input/output variables are threadvars loading them into
a temp once is faster. Create a temp which will hold a pointer to the file }
@ -1187,34 +1212,14 @@ implementation
{ typecheckpassed if the resultdef of the temp is known) }
typecheckpass(tnode(filetemp));
if not is_rwstr then
begin
{ assign the address of the file to the temp }
if do_read then
name := 'input'
else
name := 'output';
addstatement(newstatement,
cassignmentnode.create(ctemprefnode.create(filetemp),
ccallnode.createintern('fpc_get_'+name,nil)));
end
{ assign the address of the file to the temp }
if do_read then
name := 'input'
else
begin
if (do_read) then
name := 'fpc_setupreadstr_'
else
name := 'fpc_setupwritestr_';
name:=name+tstringdef(filepara.resultdef).stringtypname;
{ remove the source/destination string parameter from the }
{ parameter chain }
left:=filepara.right;
filepara.right:=nil;
{ pass the source/destination string to the setup routine, which }
{ will store the string's address in the returned textrec }
addstatement(newstatement,
cassignmentnode.create(ctemprefnode.create(filetemp),
ccallnode.createintern(name,filepara)));
end;
name := 'output';
addstatement(newstatement,
cassignmentnode.create(ctemprefnode.create(filetemp),
ccallnode.createintern('fpc_get_'+name,nil)));
{ create a new fileparameter as follows: file_type(temp^) }
{ (so that we pass the value and not the address of the temp }

16
rtl/inc/compproc.inc
View File

@ -376,26 +376,26 @@ Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); comp
{ all var rather than out, because they must not be trashed/finalized as they
can appear inside the other arguments of writerstr }
function fpc_SetupWriteStr_Shortstr(var s: shortstring): PText; compilerproc;
procedure fpc_SetupWriteStr_Shortstr(var ReadWriteStrText: text; var s: shortstring); compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
function fpc_SetupWriteStr_Ansistr(var s: ansistring): PText; compilerproc;
procedure fpc_SetupWriteStr_Ansistr(var ReadWriteStrText: text; var s: ansistring); compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
function fpc_SetupWriteStr_Unicodestr(var s: unicodestring): PText; compilerproc;
procedure fpc_SetupWriteStr_Unicodestr(var ReadWriteStrText: text; var s: unicodestring); compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
function fpc_SetupWriteStr_Widestr(var s: widestring): PText; compilerproc;
procedure fpc_SetupWriteStr_Widestr(var ReadWriteStrText: text; var s: widestring); compilerproc;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
function fpc_SetupReadStr_Shortstr(const s: shortstring): PText; compilerproc;
procedure fpc_SetupReadStr_Shortstr(var ReadWriteStrText: text; const s: shortstring); compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
function fpc_SetupReadStr_Ansistr(const s: ansistring): PText; compilerproc;
procedure fpc_SetupReadStr_Ansistr(var ReadWriteStrText: text; const s: ansistring); compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
function fpc_SetupReadStr_Unicodestr(const s: unicodestring): PText; compilerproc;
procedure fpc_SetupReadStr_Unicodestr(var ReadWriteStrText: text; const s: unicodestring); compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
function fpc_SetupReadStr_Widestr(const s: widestring): PText; compilerproc;
procedure fpc_SetupReadStr_Widestr(var ReadWriteStrText: text; const s: widestring); compilerproc;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ $endif FPC_HAS_FEATURE_TEXTIO}

88
rtl/inc/text.inc
View File

@ -1893,13 +1893,6 @@ const
{ how many bytes of the string have been processed already (used for readstr) }
BytesReadIndex = 17;
{$ifdef FPC_HAS_FEATURE_THREADING}
ThreadVar
{$else FPC_HAS_FEATURE_THREADING}
Var
{$endif FPC_HAS_FEATURE_THREADING}
ReadWriteStrText: textrec;
procedure WriteStrShort(var t: textrec);
var
str: pshortstring;
@ -2041,66 +2034,62 @@ begin
end;
function fpc_SetupWriteStr_Shortstr(var s: shortstring): PText; compilerproc;
procedure fpc_SetupWriteStr_Shortstr(var ReadWriteStrText: text; var s: shortstring); compilerproc;
begin
setupwritestrcommon(ReadWriteStrText);
PPointer(@ReadWriteStrText.userdata[StrPtrIndex])^:=@s;
setupwritestrcommon(TextRec(ReadWriteStrText));
PPointer(@TextRec(ReadWriteStrText).userdata[StrPtrIndex])^:=@s;
{ temporary destination (see comments for TempWriteStrDestIndex) }
getmem(PPointer(@ReadWriteStrText.userdata[TempWriteStrDestIndex])^,high(s)+1);
setlength(pshortstring(ppointer(@ReadWriteStrText.userdata[TempWriteStrDestIndex])^)^,0);
getmem(PPointer(@TextRec(ReadWriteStrText).userdata[TempWriteStrDestIndex])^,high(s)+1);
setlength(pshortstring(ppointer(@TextRec(ReadWriteStrText).userdata[TempWriteStrDestIndex])^)^,0);
ReadWriteStrText.userdata[ShortStrLenIndex]:=high(s);
ReadWriteStrText.InOutFunc:=@WriteStrShort;
ReadWriteStrText.FlushFunc:=@WriteStrShortFlush;
result:=@ReadWriteStrText;
TextRec(ReadWriteStrText).userdata[ShortStrLenIndex]:=high(s);
TextRec(ReadWriteStrText).InOutFunc:=@WriteStrShort;
TextRec(ReadWriteStrText).FlushFunc:=@WriteStrShortFlush;
end;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
function fpc_SetupWriteStr_Ansistr(var s: ansistring): PText; compilerproc;
procedure fpc_SetupWriteStr_Ansistr(var ReadWriteStrText: text; var s: ansistring); compilerproc;
begin
setupwritestrcommon(ReadWriteStrText);
PPointer(@ReadWriteStrText.userdata[StrPtrIndex])^:=@s;
setupwritestrcommon(TextRec(ReadWriteStrText));
PPointer(@TextRec(ReadWriteStrText).userdata[StrPtrIndex])^:=@s;
{ temp destination ansistring, nil = empty string }
PPointer(@ReadWriteStrText.userdata[TempWriteStrDestIndex])^:=nil;
PPointer(@TextRec(ReadWriteStrText).userdata[TempWriteStrDestIndex])^:=nil;
ReadWriteStrText.InOutFunc:=@WriteStrAnsi;
ReadWriteStrText.FlushFunc:=@WriteStrAnsiFlush;
result:=@ReadWriteStrText;
TextRec(ReadWriteStrText).InOutFunc:=@WriteStrAnsi;
TextRec(ReadWriteStrText).FlushFunc:=@WriteStrAnsiFlush;
end;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
function fpc_SetupWriteStr_Unicodestr(var s: unicodestring): PText; compilerproc;
procedure fpc_SetupWriteStr_Unicodestr(var ReadWriteStrText: text; var s: unicodestring); compilerproc;
begin
setupwritestrcommon(ReadWriteStrText);
PPointer(@ReadWriteStrText.userdata[StrPtrIndex])^:=@s;
setupwritestrcommon(TextRec(ReadWriteStrText));
PPointer(@TextRec(ReadWriteStrText).userdata[StrPtrIndex])^:=@s;
{ temp destination unicodestring, nil = empty string }
PPointer(@ReadWriteStrText.userdata[TempWriteStrDestIndex])^:=nil;
PPointer(@TextRec(ReadWriteStrText).userdata[TempWriteStrDestIndex])^:=nil;
ReadWriteStrText.InOutFunc:=@WriteStrUnicode;
ReadWriteStrText.FlushFunc:=@WriteStrUnicodeFlush;
result:=@ReadWriteStrText;
TextRec(ReadWriteStrText).InOutFunc:=@WriteStrUnicode;
TextRec(ReadWriteStrText).FlushFunc:=@WriteStrUnicodeFlush;
end;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
function fpc_SetupWriteStr_Widestr(var s: widestring): PText; compilerproc;
procedure fpc_SetupWriteStr_Widestr(var ReadWriteStrText: text; var s: widestring); compilerproc;
begin
setupwritestrcommon(ReadWriteStrText);
PPointer(@ReadWriteStrText.userdata[StrPtrIndex])^:=@s;
setupwritestrcommon(TextRec(ReadWriteStrText));
PPointer(@TextRec(ReadWriteStrText).userdata[StrPtrIndex])^:=@s;
{ temp destination widestring }
PWideString(@ReadWriteStrText.userdata[TempWriteStrDestIndex])^:='';
PWideString(@TextRec(ReadWriteStrText).userdata[TempWriteStrDestIndex])^:='';
ReadWriteStrText.InOutFunc:=@WriteStrWide;
ReadWriteStrText.FlushFunc:=@WriteStrWideFlush;
result:=@ReadWriteStrText;
TextRec(ReadWriteStrText).InOutFunc:=@WriteStrWide;
TextRec(ReadWriteStrText).FlushFunc:=@WriteStrWideFlush;
end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
@ -2155,22 +2144,21 @@ end;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
function fpc_SetupReadStr_Ansistr(const s: ansistring): PText; [public, alias: 'FPC_SETUPREADSTR_ANSISTR']; compilerproc;
procedure fpc_SetupReadStr_Ansistr(var ReadWriteStrText: text; const s: ansistring); [public, alias: 'FPC_SETUPREADSTR_ANSISTR']; compilerproc;
begin
setupreadstrcommon(ReadWriteStrText);
setupreadstrcommon(TextRec(ReadWriteStrText));
{ we need a reference, because 's' may be a temporary expression }
PAnsiString(@ReadWriteStrText.userdata[StrPtrIndex])^:=s;
ReadWriteStrText.InOutFunc:=@ReadStrAnsi;
PAnsiString(@TextRec(ReadWriteStrText).userdata[StrPtrIndex])^:=s;
TextRec(ReadWriteStrText).InOutFunc:=@ReadStrAnsi;
{ this is called at the end, by fpc_read_end }
ReadWriteStrText.FlushFunc:=@ReadAnsiStrFinal;
result:=@ReadWriteStrText;
TextRec(ReadWriteStrText).FlushFunc:=@ReadAnsiStrFinal;
end;
function fpc_SetupReadStr_Ansistr_Intern(const s: ansistring): PText; [external name 'FPC_SETUPREADSTR_ANSISTR'];
procedure fpc_SetupReadStr_Ansistr_Intern(var ReadWriteStrText: text; const s: ansistring); [external name 'FPC_SETUPREADSTR_ANSISTR'];
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
function fpc_SetupReadStr_Shortstr(const s: shortstring): PText; compilerproc;
procedure fpc_SetupReadStr_Shortstr(var ReadWriteStrText: text; const s: shortstring); compilerproc;
begin
{ the reason we convert the short string to ansistring, is because the semantics of
readstr are defined as:
@ -2197,7 +2185,7 @@ begin
to use the other ansistring readstr helpers too.
}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
result:=fpc_SetupReadStr_Ansistr_Intern(s);
fpc_SetupReadStr_Ansistr_Intern(ReadWriteStrText,s);
{$else FPC_HAS_FEATURE_ANSISTRINGS}
runerror(217);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
@ -2205,21 +2193,21 @@ end;
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
function fpc_SetupReadStr_Unicodestr(const s: unicodestring): PText; compilerproc;
procedure fpc_SetupReadStr_Unicodestr(var ReadWriteStrText: text; const s: unicodestring); compilerproc;
begin
{ we use an ansistring to avoid code duplication, and let the }
{ assignment convert the widestring to an equivalent ansistring }
result:=fpc_SetupReadStr_Ansistr_Intern(s);
fpc_SetupReadStr_Ansistr_Intern(ReadWriteStrText,s);
end;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
function fpc_SetupReadStr_Widestr(const s: widestring): PText; compilerproc;
procedure fpc_SetupReadStr_Widestr(var ReadWriteStrText: text; const s: widestring); compilerproc;
begin
{ we use an ansistring to avoid code duplication, and let the }
{ assignment convert the widestring to an equivalent ansistring }
result:=fpc_SetupReadStr_Ansistr_Intern(s);
fpc_SetupReadStr_Ansistr_Intern(ReadWriteStrText,s);
end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}

16
rtl/java/jcompproc.inc
View File

@ -340,26 +340,26 @@ Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); comp
{ all var rather than out, because they must not be trashed/finalized as they
can appear inside the other arguments of writerstr }
function fpc_SetupWriteStr_Shortstr(var s: shortstring): PText; compilerproc;
procedure fpc_SetupWriteStr_Shortstr(var ReadWriteStrText: text; var s: shortstring); compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
function fpc_SetupWriteStr_Ansistr(var s: ansistring): PText; compilerproc;
procedure fpc_SetupWriteStr_Ansistr(var ReadWriteStrText: text; var s: ansistring); compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
function fpc_SetupWriteStr_Unicodestr(var s: unicodestring): PText; compilerproc;
procedure fpc_SetupWriteStr_Unicodestr(var ReadWriteStrText: text; var s: unicodestring); compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
function fpc_SetupWriteStr_Widestr(var s: widestring): PText; compilerproc;
procedure fpc_SetupWriteStr_Widestr(var ReadWriteStrText: text; var s: widestring); compilerproc;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
function fpc_SetupReadStr_Shortstr(const s: shortstring): PText; compilerproc;
procedure fpc_SetupReadStr_Shortstr(var ReadWriteStrText: text; const s: shortstring); compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
function fpc_SetupReadStr_Ansistr(const s: ansistring): PText; compilerproc;
procedure fpc_SetupReadStr_Ansistr(var ReadWriteStrText: text; const s: ansistring); compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
function fpc_SetupReadStr_Unicodestr(const s: unicodestring): PText; compilerproc;
procedure fpc_SetupReadStr_Unicodestr(var ReadWriteStrText: text; const s: unicodestring); compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
function fpc_SetupReadStr_Widestr(const s: widestring): PText; compilerproc;
procedure fpc_SetupReadStr_Widestr(var ReadWriteStrText: text; const s: widestring); compilerproc;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$endif FPC_HAS_FEATURE_TEXTIO}

93
tests/webtbs/tw23912.pp Normal file
View File

@ -0,0 +1,93 @@
program crash_2_7_1;
{$mode objfpc}{$H+}
//uses
type
TSynCommentType = (sctAnsi, sctBor, sctSlash);
TSynCommentIndentFlag = (
// * For Matching lines (FCommentMode)
// By default indent is the same as for none comment lines (none overrides sciAlignOpen)
sciNone, // Does not Indent comment lines (Prefix may contain a fixed indent)
sciAlignOpen, // Indent to real opening pos on first line, if comment does not start at BOL "Foo(); (*"
sciAddTokenLen, // add 1 or 2 spaces to indent (for the length of the token)
sciAddPastTokenIndent, // Adds any indent found past the opening token "(*", "{" or "//".
sciMatchOnlyTokenLen, // Apply the Above only if first line matches. (Only if sciAddTokenLen is specified)
sciMatchOnlyPastTokenIndent,
sciAlignOnlyTokenLen, // Apply the Above only if sciAlignOpen was used (include via max)
sciAlignOnlyPastTokenIndent,
sciApplyIndentForNoMatch // Apply above rules For NONE Matching lines (FCommentMode),
// includes FIndentFirstLineExtra
);
TSynCommentIndentFlags = set of TSynCommentIndentFlag;
TSynCommentContineMode = (
sccNoPrefix, // May still do indent, if matched
sccPrefixAlways, // If the pattern did not match all will be done, except the indent AFTER the prefix (can not be detected)
sccPrefixMatch
);
TSynCommentMatchMode = (
scmMatchAfterOpening, // will not include (*,{,//. The ^ will match the first char after
scmMatchOpening, // will include (*,{,//. The ^ will match the ({/
scmMatchWholeLine, // Match the entire line
scmMatchAtAsterisk // AnsiComment only, will match the * of (*, but not the (
);
TSynCommentMatchLine = (
sclMatchFirst, // Match the first line of the comment to get substitutes for Prefix ($1)
sclMatchPrev // Match the previous line of the comment to get substitutes for Prefix ($1)
);
TSynBeautifierIndentType = (sbitSpace, sbitCopySpaceTab, sbitPositionCaret);
TSynCommentExtendMode = (
sceNever, // Never Extend
sceAlways, // Always
sceSplitLine, // If the line was split (caret was not at EOL, when enter was pressed
sceMatching, // If the line matched (even if sccPrefixAlways or sccNoPrefix
sceMatchingSplitLine
);
function dbgs(AIndentFlag: TSynCommentIndentFlag): String;
begin
Result := ''; WriteStr(Result, AIndentFlag);
end;
function dbgs(AIndentFlags: TSynCommentIndentFlags): String;
var
i: TSynCommentIndentFlag;
begin
Result := '';
for i := low(TSynCommentIndentFlag) to high(TSynCommentIndentFlag) do
if i in AIndentFlags then
if Result = ''
then Result := dbgs(i)
else Result := Result + ',' + dbgs(i);
if Result <> '' then
Result := '[' + Result + ']';
end;
procedure Foo(Atype: TSynCommentType;
AIndentMode: TSynCommentIndentFlags;
AIndentFirstLineMax: Integer; AIndentFirstLineExtra: String;
ACommentMode: TSynCommentContineMode; AMatchMode: TSynCommentMatchMode;
AMatchLine: TSynCommentMatchLine; ACommentIndent: TSynBeautifierIndentType;
AMatch: String; APrefix: String;
AExtenbSlash: TSynCommentExtendMode = sceNever);
var
s: String;
begin
writestr(s, AType,':',
' IMode=', dbgs(AIndentMode), ' IMax=', AIndentFirstLineMax, ' IExtra=', AIndentFirstLineExtra,
' CMode=', ACommentMode, ' CMatch=', AMatchMode, ' CLine=', AMatchLine,
' M=''', AMatch, ''' R=''', APrefix, ''' CIndent=', ACommentIndent
);
if s<>'sctAnsi: IMode=[sciAddTokenLen] IMax=5 IExtra= CMode=sccPrefixMatch CMatch=scmMatchOpening CLine=sclMatchPrev M=''.'' R=''+'' CIndent=sbitCopySpaceTab' then
halt(1);
end;
begin
Foo(sctAnsi, [sciAddTokenLen], 5, ' ', sccPrefixMatch, scmMatchOpening,
sclMatchPrev, sbitCopySpaceTab, '.', '+');
end.