From c80d4225ca5cc52a65340c0d743669abdaed3ecc Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Mon, 14 May 2007 17:34:01 +0000 Subject: [PATCH] + support for ISO Extended Pascal ReadStr() and WriteStr() routines git-svn-id: trunk@7333 - --- .gitattributes | 16 ++++ compiler/compinnr.inc | 2 + compiler/ninl.pas | 86 +++++++++++++---- compiler/pexpr.pas | 6 +- compiler/psystem.pas | 2 + rtl/inc/compproc.inc | 8 ++ rtl/inc/innr.inc | 2 + rtl/inc/text.inc | 218 ++++++++++++++++++++++++++++++++++++++++++ tests/test/trstr1.pp | 15 +++ tests/test/trstr2.pp | 10 ++ tests/test/trstr3.pp | 5 + tests/test/trstr4.pp | 8 ++ tests/test/trstr5.pp | 8 ++ tests/test/trstr6.pp | 29 ++++++ tests/test/trstr7.pp | 13 +++ tests/test/trstr8.pp | 19 ++++ tests/test/twrstr1.pp | 15 +++ tests/test/twrstr2.pp | 12 +++ tests/test/twrstr3.pp | 21 ++++ tests/test/twrstr4.pp | 7 ++ tests/test/twrstr5.pp | 5 + tests/test/twrstr6.pp | 7 ++ tests/test/twrstr7.pp | 15 +++ tests/test/twrstr8.pp | 39 ++++++++ 24 files changed, 548 insertions(+), 20 deletions(-) create mode 100644 tests/test/trstr1.pp create mode 100644 tests/test/trstr2.pp create mode 100644 tests/test/trstr3.pp create mode 100644 tests/test/trstr4.pp create mode 100644 tests/test/trstr5.pp create mode 100644 tests/test/trstr6.pp create mode 100644 tests/test/trstr7.pp create mode 100644 tests/test/trstr8.pp create mode 100644 tests/test/twrstr1.pp create mode 100644 tests/test/twrstr2.pp create mode 100644 tests/test/twrstr3.pp create mode 100644 tests/test/twrstr4.pp create mode 100644 tests/test/twrstr5.pp create mode 100644 tests/test/twrstr6.pp create mode 100644 tests/test/twrstr7.pp create mode 100644 tests/test/twrstr8.pp diff --git a/.gitattributes b/.gitattributes index 1b1757e8b0..bf9d9f7900 100644 --- a/.gitattributes +++ b/.gitattributes @@ -6904,6 +6904,14 @@ tests/test/trecreg2.pp svneol=native#text/plain tests/test/trecreg3.pp -text tests/test/trecreg4.pp svneol=native#text/plain tests/test/tresstr.pp svneol=native#text/plain +tests/test/trstr1.pp svneol=native#text/plain +tests/test/trstr2.pp svneol=native#text/plain +tests/test/trstr3.pp svneol=native#text/plain +tests/test/trstr4.pp svneol=native#text/plain +tests/test/trstr5.pp svneol=native#text/plain +tests/test/trstr6.pp svneol=native#text/plain +tests/test/trstr7.pp svneol=native#text/plain +tests/test/trstr8.pp svneol=native#text/plain tests/test/trtti1.pp svneol=native#text/plain tests/test/trtti2.pp svneol=native#text/plain tests/test/trtti3.pp svneol=native#text/plain @@ -6942,6 +6950,14 @@ tests/test/tvarset1.pp svneol=native#text/plain tests/test/tw6727.pp svneol=native#text/plain tests/test/twide1.pp svneol=native#text/plain tests/test/twide2.pp svneol=native#text/plain +tests/test/twrstr1.pp svneol=native#text/plain +tests/test/twrstr2.pp svneol=native#text/plain +tests/test/twrstr3.pp svneol=native#text/plain +tests/test/twrstr4.pp svneol=native#text/plain +tests/test/twrstr5.pp svneol=native#text/plain +tests/test/twrstr6.pp svneol=native#text/plain +tests/test/twrstr7.pp svneol=native#text/plain +tests/test/twrstr8.pp svneol=native#text/plain tests/test/uabstrcl.pp svneol=native#text/plain tests/test/uenum2a.pp svneol=native#text/plain tests/test/uenum2b.pp svneol=native#text/plain diff --git a/compiler/compinnr.inc b/compiler/compinnr.inc index 28b94bc0be..e990c3be3e 100644 --- a/compiler/compinnr.inc +++ b/compiler/compinnr.inc @@ -69,6 +69,8 @@ const in_pack_x_y_z = 59; in_unpack_x_y_z = 60; in_bitsizeof_x = 61; + in_writestr_x = 62; + in_readstr_x = 63; { Internal constant functions } in_const_sqr = 100; diff --git a/compiler/ninl.pas b/compiler/ninl.pas index a6abb3493a..50119fe469 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -364,7 +364,7 @@ implementation begin para:=Tcallparanode(params); found_error:=false; - do_read:=inlinenumber in [in_read_x,in_readln_x]; + do_read:=inlinenumber in [in_read_x,in_readln_x,in_readstr_x]; while assigned(para) do begin { is this parameter faulty? } @@ -710,9 +710,11 @@ implementation if not found_error then begin case inlinenumber of - in_read_x: + in_read_x, + in_readstr_x: name:='fpc_read_end'; - in_write_x: + in_write_x, + in_writestr_x: name:='fpc_write_end'; in_readln_x: name:='fpc_readln_end'; @@ -729,9 +731,9 @@ implementation {Read/write for typed files.} const procprefixes:array[boolean] of string[15]=('fpc_typed_write','fpc_typed_read'); - procnamesdisplay:array[boolean] of string[5] = ('Write','Read'); + procnamesdisplay:array[boolean,boolean] of string[8] = (('Write','Read'),('WriteStr','ReadStr')); - var found_error,do_read:boolean; + var found_error,do_read,is_rwstr:boolean; para,nextpara:Tcallparanode; p1:Tnode; temp:Ttempcreatenode; @@ -739,7 +741,8 @@ implementation begin found_error:=false; para:=Tcallparanode(params); - do_read:=inlinenumber in [in_read_x,in_readln_x]; + do_read:=inlinenumber in [in_read_x,in_readln_x,in_readstr_x]; + is_rwstr := inlinenumber in [in_readstr_x,in_writestr_x]; { add the typesize to the filepara } if filepara.resultdef.typ=filedef then filepara.right := ccallparanode.create(cordconstnode.create( @@ -748,7 +751,7 @@ implementation { check for "no parameters" (you need at least one extra para for typed files) } if not assigned(para) then begin - CGMessage1(parser_e_wrong_parameter_size,procnamesdisplay[do_read]); + CGMessage1(parser_e_wrong_parameter_size,procnamesdisplay[is_rwstr,do_read]); found_error := true; end; @@ -847,12 +850,15 @@ implementation readfunctype : tdef; is_typed, do_read, + is_rwstr, found_error : boolean; begin filepara := nil; is_typed := false; filetemp := nil; - do_read := inlinenumber in [in_read_x,in_readln_x]; + do_read := inlinenumber in [in_read_x,in_readln_x,in_readstr_x]; + is_rwstr := inlinenumber in [in_readstr_x,in_writestr_x]; + { if we fail, we can quickly exit this way. We must generate something } { instead of the inline node, because firstpass will bomb with an } { internalerror if it encounters a read/write } @@ -862,7 +868,28 @@ implementation { correct order when processing write(ln) } left := reverseparameters(tcallparanode(left)); - if assigned(left) then + if is_rwstr then + begin + filepara := tcallparanode(left); + { needs at least two parameters: source/dest string + min. 1 value } + if not(assigned(filepara)) or + not(assigned(filepara.right)) then + begin + CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,'ReadStr/WriteStr'); + exit; + end + else if (filepara.resultdef.typ <> stringdef) then + begin + { convert chararray to string, or give an appropriate error message } + { (if you want to optimize to use shortstring, keep in mind that } + { readstr internally always uses ansistring, and to account for } + { chararrays with > 255 characters) } + inserttypeconv(filepara.left,cansistringtype); + if codegenerror then + exit; + end + end + else if assigned(left) then begin { check if we have a file parameter and if yes, what kind it is } filepara := tcallparanode(left); @@ -897,7 +924,8 @@ implementation newblock:=internalstatements(newstatement); { if we don't have a filepara, create one containing the default } - if not assigned(filepara) then + if not assigned(filepara) or + is_rwstr 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 } @@ -911,14 +939,34 @@ implementation { typecheckpassed if the resultdef of the temp is known) } typecheckpass(tnode(filetemp)); - { assign the address of the file to the temp } - if do_read then - name := 'input' + 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 else - name := 'output'; - addstatement(newstatement, - cassignmentnode.create(ctemprefnode.create(filetemp), - ccallnode.createintern('fpc_get_'+name,nil))); + 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; { create a new fileparameter as follows: file_type(temp^) } { (so that we pass the value and not the address of the temp } @@ -1935,8 +1983,10 @@ implementation in_read_x, in_readln_x, + in_readstr_x, in_write_x, - in_writeln_x : + in_writeln_x, + in_writestr_x : begin result := handle_read_write; end; diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 735ab5bc36..62986576f9 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -782,7 +782,8 @@ implementation end; in_read_x, - in_readln_x : + in_readln_x, + in_readstr_x: begin if try_to_consume(_LKLAMMER) then begin @@ -811,7 +812,8 @@ implementation end; in_write_x, - in_writeln_x : + in_writeln_x, + in_writestr_x : begin if try_to_consume(_LKLAMMER) then begin diff --git a/compiler/psystem.pas b/compiler/psystem.pas index b57874399f..01fa86e21f 100644 --- a/compiler/psystem.pas +++ b/compiler/psystem.pas @@ -57,9 +57,11 @@ implementation systemunit.insert(tsyssym.create('Concat',in_concat_x)); systemunit.insert(tsyssym.create('Write',in_write_x)); systemunit.insert(tsyssym.create('WriteLn',in_writeln_x)); + systemunit.insert(tsyssym.create('WriteStr',in_writestr_x)); systemunit.insert(tsyssym.create('Assigned',in_assigned_x)); systemunit.insert(tsyssym.create('Read',in_read_x)); systemunit.insert(tsyssym.create('ReadLn',in_readln_x)); + systemunit.insert(tsyssym.create('ReadStr',in_readstr_x)); systemunit.insert(tsyssym.create('Ofs',in_ofs_x)); systemunit.insert(tsyssym.create('SizeOf',in_sizeof_x)); systemunit.insert(tsyssym.create('BitSizeOf',in_bitsizeof_x)); diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc index 1fd6ef45f4..015a4beb80 100644 --- a/rtl/inc/compproc.inc +++ b/rtl/inc/compproc.inc @@ -278,6 +278,14 @@ Procedure fpc_Write_Text_Currency(fixkomma,Len : Longint;var t : Text;c : Curren Procedure fpc_Write_Text_Boolean(Len : Longint;var t : Text;b : Boolean); compilerproc; Procedure fpc_Write_Text_Char(Len : Longint;var t : Text;c : Char); compilerproc; Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); compilerproc; + +function fpc_SetupWriteStr_Shortstr(out s: shortstring): PText; compilerproc; +function fpc_SetupWriteStr_Ansistr(out s: ansistring): PText; compilerproc; +function fpc_SetupWriteStr_Widestr(out s: widestring): PText; compilerproc; + +function fpc_SetupReadStr_Shortstr(const s: shortstring): PText; compilerproc; +function fpc_SetupReadStr_Ansistr(const s: ansistring): PText; compilerproc; +function fpc_SetupReadStr_Widestr(const s: widestring): PText; compilerproc; {$endif FPC_HAS_FEATURE_TEXTIO} {$ifdef FPC_HAS_FEATURE_VARIANTS} diff --git a/rtl/inc/innr.inc b/rtl/inc/innr.inc index cbf22c29cf..7c9d337ed6 100644 --- a/rtl/inc/innr.inc +++ b/rtl/inc/innr.inc @@ -70,6 +70,8 @@ const fpc_in_pack_x_y_z = 59; fpc_in_unpack_x_y_z = 60; fpc_in_bitsizeof_x = 61; + fpc_in_writestr_x = 62; + fpc_in_readstr_x = 63; { Internal constant functions } fpc_in_const_sqr = 100; diff --git a/rtl/inc/text.inc b/rtl/inc/text.inc index 0a65469813..7e675c90f1 100644 --- a/rtl/inc/text.inc +++ b/rtl/inc/text.inc @@ -1288,6 +1288,224 @@ End; {$endif CPU64} + +{***************************************************************************** + WriteStr/ReadStr +*****************************************************************************} + +const + StrPtrIndex = 1; + { leave space for 128 bit string pointers :) (used for writestr) } + ShortStrLenIndex = 17; + { how many bytes of the string have been processed already (used for readstr) } + BytesReadIndex = 17; + +threadvar + ReadWriteStrText: textrec; + +procedure WriteStrShort(var t: textrec); +var + str: pshortstring; + newbytes, + oldlen: longint; +begin + if (t.bufpos=0) then + exit; + str:=pshortstring(ppointer(@t.userdata[StrPtrIndex])^); + newbytes:=t.BufPos; + oldlen:=length(str^); + if (oldlen+t.bufpos > t.userdata[ShortStrLenIndex]) then + begin + newbytes:=t.userdata[ShortStrLenIndex]-oldlen; +{$ifdef writestr_iolencheck} + // GPC only gives an io error if {$no-truncate-strings} is active + // FPC does not have this setting (it always gives errors when a + // a string expression is truncated) + + { "disk full" } + inoutres:=101; +{$endif} + end; + setlength(str^,length(str^)+newbytes); + move(t.bufptr^,str^[oldlen+1],newbytes); + t.bufpos:=0; +end; + + +procedure WriteStrAnsi(var t: textrec); +var + str: pansistring; + newbytes, + oldlen: longint; +begin + if (t.bufpos=0) then + exit; + str:=pansistring(ppointer(@t.userdata[StrPtrIndex])^); + oldlen:=length(str^); + setlength(str^,oldlen+t.bufpos); + move(t.bufptr^,str^[oldlen+1],t.bufpos); + t.bufpos:=0; +end; + + +procedure WriteStrWide(var t: textrec); +var + temp: ansistring; + str: pwidestring; +begin + if (t.bufpos=0) then + exit; + str:=pwidestring(ppointer(@t.userdata[StrPtrIndex])^); + setlength(temp,t.bufpos); + move(t.bufptr^,temp[1],t.bufpos); + str^:=str^+temp; + t.bufpos:=0; +end; + + +procedure SetupWriteStrCommon(out t: textrec); +begin + // initialise + Assign(text(t),''); + t.mode:=fmOutput; + t.OpenFunc:=nil; + t.CloseFunc:=nil; +end; + + +function fpc_SetupWriteStr_Shortstr(out s: shortstring): PText; compilerproc; +begin + setupwritestrcommon(ReadWriteStrText); + PPointer(@ReadWriteStrText.userdata[StrPtrIndex])^:=@s; + ReadWriteStrText.userdata[ShortStrLenIndex]:=high(s); + setlength(s,0); + ReadWriteStrText.InOutFunc:=@WriteStrShort; + ReadWriteStrText.FlushFunc:=@WriteStrShort; + result:=@ReadWriteStrText; +end; + + +function fpc_SetupWriteStr_Ansistr(out s: ansistring): PText; compilerproc; +begin + setupwritestrcommon(ReadWriteStrText); + PPointer(@ReadWriteStrText.userdata[StrPtrIndex])^:=@s; +// automatically done by out-semantics +// setlength(s,0); + ReadWriteStrText.InOutFunc:=@WriteStrAnsi; + ReadWriteStrText.FlushFunc:=@WriteStrAnsi; + result:=@ReadWriteStrText; +end; + + +function fpc_SetupWriteStr_Widestr(out s: widestring): PText; compilerproc; +begin + setupwritestrcommon(ReadWriteStrText); + PPointer(@ReadWriteStrText.userdata[StrPtrIndex])^:=@s; +// automatically done by out-semantics +// setlength(s,0); + ReadWriteStrText.InOutFunc:=@WriteStrWide; + ReadWriteStrText.FlushFunc:=@WriteStrWide; + result:=@ReadWriteStrText; +end; + + + +procedure ReadAnsiStrFinal(var t: textrec); +begin + { finalise the temp ansistring } + PAnsiString(@t.userdata[StrPtrIndex])^ := ''; +end; + + +procedure ReadStrCommon(var t: textrec; strdata: pchar; len: sizeint); +var + newbytes: sizeint; +begin + newbytes := len - PSizeInt(@t.userdata[BytesReadIndex])^; + if (t.BufSize <= newbytes) then + newbytes := t.BufSize; + if (newbytes > 0) then + begin + move(strdata[PSizeInt(@t.userdata[BytesReadIndex])^],t.BufPtr^,newbytes); + inc(PSizeInt(@t.userdata[BytesReadIndex])^,newbytes); + end; + t.BufEnd:=newbytes; + t.BufPos:=0; +end; + + +procedure ReadStrAnsi(var t: textrec); +var + str: pansistring; +begin + str:=pansistring(@t.userdata[StrPtrIndex]); + ReadStrCommon(t,@str^[1],length(str^)); +end; + + +procedure SetupReadStrCommon(out t: textrec); +begin + // initialise + Assign(text(t),''); + t.mode:=fmInput; + t.OpenFunc:=nil; + t.CloseFunc:=nil; + PSizeInt(@t.userdata[BytesReadIndex])^:=0; +end; + + +function fpc_SetupReadStr_Ansistr(const s: ansistring): PText; [public, alias: 'FPC_SETUPREADSTR_ANSISTR']; compilerproc; +begin + setupreadstrcommon(ReadWriteStrText); + { we need a reference, because 's' may be a temporary expression } + PAnsiString(@ReadWriteStrText.userdata[StrPtrIndex])^:=s; + ReadWriteStrText.InOutFunc:=@ReadStrAnsi; + { this is called at the end, by fpc_read_end } + ReadWriteStrText.FlushFunc:=@ReadAnsiStrFinal; + result:=@ReadWriteStrText; +end; + +function fpc_SetupReadStr_Ansistr_Intern(const s: ansistring): PText; [external name 'FPC_SETUPREADSTR_ANSISTR']; + + +function fpc_SetupReadStr_Shortstr(const s: shortstring): PText; compilerproc; +begin + { the reason we convert the short string to ansistring, is because the semantics of + readstr are defined as: + + ********************* + Apart from the restrictions imposed by requirements given in this clause, + the execution of readstr(e,v 1 ,...,v n ) where e denotes a + string-expression and v 1 ,...,v n denote variable-accesses possessing the + char-type (or a subrange of char-type), the integer-type (or a subrange of + integer-type), the real-type, a fixed-string-type, or a + variable-string-type, shall be equivalent to + + begin + rewrite(f); + writeln(f, e); + reset(f); + read(f, v 1 ,...,v n ) + end + ********************* + + This means that any side effects caused by the evaluation of v 1 .. v n + must not affect the value of e (= our argument s) -> we need a copy of it. + An ansistring is the easiest way to get a threadsafe copy, and allows us + to use the other ansistring readstr helpers too. + } + result:=fpc_SetupReadStr_Ansistr_Intern(s); +end; + + +function fpc_SetupReadStr_Widestr(const s: widestring): PText; 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); +end; + + {***************************************************************************** Initializing *****************************************************************************} diff --git a/tests/test/trstr1.pp b/tests/test/trstr1.pp new file mode 100644 index 0000000000..1fc7463804 --- /dev/null +++ b/tests/test/trstr1.pp @@ -0,0 +1,15 @@ +var + s: ansistring; + i,j: integer; + c1,c2: char; +begin + s := '15'; + { temp ansistring must be kept until read is finished } + readstr(s+' ,305',i,c1,c2,j); + if (i <> 15) or + (c1 <> ' ') or + (c2 <> ',') or + (j <> 305) then + halt(1); +end. + diff --git a/tests/test/trstr2.pp b/tests/test/trstr2.pp new file mode 100644 index 0000000000..7ae836e52a --- /dev/null +++ b/tests/test/trstr2.pp @@ -0,0 +1,10 @@ +var + s: ansistring; + i,j: integer; +begin + s := '15 305'; + readstr(s,i,j); + if (i <> 15) or + (j <> 305) then + halt(1); +end. diff --git a/tests/test/trstr3.pp b/tests/test/trstr3.pp new file mode 100644 index 0000000000..be315b7c09 --- /dev/null +++ b/tests/test/trstr3.pp @@ -0,0 +1,5 @@ +{ %fail } + +begin + readstr; +end. diff --git a/tests/test/trstr4.pp b/tests/test/trstr4.pp new file mode 100644 index 0000000000..de54ddb091 --- /dev/null +++ b/tests/test/trstr4.pp @@ -0,0 +1,8 @@ +{ %fail } + +var + s: string; +begin + s:='abc'; + readstr(s); +end. diff --git a/tests/test/trstr5.pp b/tests/test/trstr5.pp new file mode 100644 index 0000000000..61585bcce9 --- /dev/null +++ b/tests/test/trstr5.pp @@ -0,0 +1,8 @@ +{ %fail } + +var + t: text; + i: integer; +begin + readstr(t,i); +end. diff --git a/tests/test/trstr6.pp b/tests/test/trstr6.pp new file mode 100644 index 0000000000..29e482517b --- /dev/null +++ b/tests/test/trstr6.pp @@ -0,0 +1,29 @@ +{ from GPC test suite } + +program rstr1(Output); +type ii = integer; + tip = ^ii; +var ipv1, ipv2, ipv3 : tip; + s : string[20]; + +function ip1: tip; + var tmp : tip; +begin + s := 'dead beef'; + tmp := ipv2; + ipv2 := ipv3; + ipv3 := tmp; + ip1 := ipv1; +end; +begin + s:='666 123'; + new(ipv1); + new(ipv2); + new(ipv3); + ipv2^ := 155; + readstr(s, ip1^, ipv2^); + if (ipv1^ = 666) and (ipv2^ = 123) and (ipv3^ = 155) then + writeln('OK') + else + halt(1); +end. diff --git a/tests/test/trstr7.pp b/tests/test/trstr7.pp new file mode 100644 index 0000000000..ce76dbcd84 --- /dev/null +++ b/tests/test/trstr7.pp @@ -0,0 +1,13 @@ +{ %result=201 } + +{ from GPC test suite } + +program mir034e; +{$r+} + +type range = 10..13; +var k : range; + +begin + ReadStr ('14', k); { over ubound } +end. diff --git a/tests/test/trstr8.pp b/tests/test/trstr8.pp new file mode 100644 index 0000000000..b9dd15ae24 --- /dev/null +++ b/tests/test/trstr8.pp @@ -0,0 +1,19 @@ +{ from GPC test suite } + +program fjf227a; + +type TString = String; + +procedure foo (const v : double); +var s : TString; +begin + repeat + WriteStr (s, '', v : 0); + ReadStr (s, s); + until (s = '') or (s <> ''); + if s = ' 4.2E+001' then writeln ('OK') else writeln ('failed "', s,'"') +end; + +begin + foo (42) +end. diff --git a/tests/test/twrstr1.pp b/tests/test/twrstr1.pp new file mode 100644 index 0000000000..6e938a9571 --- /dev/null +++ b/tests/test/twrstr1.pp @@ -0,0 +1,15 @@ +{ %fail } + +{ from GPC testsuite } + +program fjf569i; + +procedure foo (const a: String); +begin + WriteStr (a, '') { WRONG } +end; + +begin + WriteLn ('') +end. + diff --git a/tests/test/twrstr2.pp b/tests/test/twrstr2.pp new file mode 100644 index 0000000000..b1759ce782 --- /dev/null +++ b/tests/test/twrstr2.pp @@ -0,0 +1,12 @@ +{ from GPC test suite } + +Program TruncSt3; + +Var + Foo: String [3]; + +begin + WriteStr (Foo, 'abcdef'); + if Foo <> 'abc' then + halt(1); +end. diff --git a/tests/test/twrstr3.pp b/tests/test/twrstr3.pp new file mode 100644 index 0000000000..3e526b8133 --- /dev/null +++ b/tests/test/twrstr3.pp @@ -0,0 +1,21 @@ +{ from GPC test suite } + +Program fjf7; + +Var + S: String [ 80 ]; + astr: ansistring; + +begin + WriteStr ( astr, '' : 5, 'OKabcdf' : 7 ); + if (length ( astr ) <> 5 + 7) or + (copy(astr,6,2) <> 'OK') then + halt(1); + + WriteStr ( S, '' : 5, 'OKabcdf' : 7 ); + if length ( S ) = 5 + 7 then + halt(ord(copy(S,6,2) <> 'OK')) + else + halt(1); +end. + diff --git a/tests/test/twrstr4.pp b/tests/test/twrstr4.pp new file mode 100644 index 0000000000..70590ed5c5 --- /dev/null +++ b/tests/test/twrstr4.pp @@ -0,0 +1,7 @@ +{ %fail } + +var + t: text; +begin + writestr(t,'abc'); +end. diff --git a/tests/test/twrstr5.pp b/tests/test/twrstr5.pp new file mode 100644 index 0000000000..7977c45d99 --- /dev/null +++ b/tests/test/twrstr5.pp @@ -0,0 +1,5 @@ +{ %fail } + +begin + writestr; +end. diff --git a/tests/test/twrstr6.pp b/tests/test/twrstr6.pp new file mode 100644 index 0000000000..bf6be853fa --- /dev/null +++ b/tests/test/twrstr6.pp @@ -0,0 +1,7 @@ +{ %fail } + +var + s: string; +begin + writestr(s); +end. diff --git a/tests/test/twrstr7.pp b/tests/test/twrstr7.pp new file mode 100644 index 0000000000..c3ac570a2c --- /dev/null +++ b/tests/test/twrstr7.pp @@ -0,0 +1,15 @@ +{ from GPC test suite } + +{$mode objfpc} +Program WriteByte; + +var + a: array [ 0..3 ] of Byte = ( ord ( 'O' ), ord ( 'K' ), 42, 137 ); + +var + S: String [ 255 ]; + +begin + WriteStr ( S, a [ 0 ], a [ 1 ] ); + halt(ord(S <> '7975')); +end. diff --git a/tests/test/twrstr8.pp b/tests/test/twrstr8.pp new file mode 100644 index 0000000000..34b1832260 --- /dev/null +++ b/tests/test/twrstr8.pp @@ -0,0 +1,39 @@ +{ from GPC test suite } + +program LongRealBug; +{ Dagegen ist Intels legend?rer Pentium-Bug eine Kleinigkeit!!!} + +const + Pi = 3.14159265358979323846; + +var + Pi_L : extended; + Pi_R : Real; + S : String [10]; + +begin + Pi_L := Pi; + Pi_R := Pi; + + WriteStr( S, sin(Pi) :10:5 ); + if ( S <> ' 0.00000' ) and ( S <> ' -0.00000' ) then + halt(1); + WriteStr( S, sin(Pi_L) :10:5 ); + if ( S <> ' 0.00000' ) and ( S <> ' -0.00000' ) then + halt(1); + WriteStr( S, sin(Pi_R) :10:5 ); + if ( S <> ' 0.00000' ) and ( S <> ' -0.00000' ) then + halt(1); + + WriteStr( S, cos(Pi) :10:5 ); + if S <> ' -1.00000' then + halt(1); + WriteStr( S, cos(Pi_L) :10:5 ); + if S <> ' -1.00000' then + halt(1); + WriteStr( S, cos(Pi_R) :10:5 ); + if S <> ' -1.00000' then + halt(1); + + writeln ( 'OK' ); +end.