+ support for ISO Extended Pascal ReadStr() and WriteStr() routines

git-svn-id: trunk@7333 -

.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

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;

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;

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

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));

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}

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;

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
 *****************************************************************************}

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.
+

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.

tests/test/trstr3.pp

@@ -0,0 +1,5 @@
+{ %fail }
+
+begin
+  readstr;
+end.

tests/test/trstr4.pp

@@ -0,0 +1,8 @@
+{ %fail }
+
+var
+  s: string;
+begin
+  s:='abc';
+  readstr(s);
+end.

tests/test/trstr5.pp

@@ -0,0 +1,8 @@
+{ %fail }
+
+var
+  t: text;
+  i: integer;
+begin
+  readstr(t,i);
+end.

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. 

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.

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.

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.
+

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.

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.
+

tests/test/twrstr4.pp

@@ -0,0 +1,7 @@
+{ %fail }
+
+var
+  t: text;
+begin
+  writestr(t,'abc');
+end.

tests/test/twrstr5.pp

@@ -0,0 +1,5 @@
+{ %fail }
+
+begin
+  writestr;
+end.

tests/test/twrstr6.pp

@@ -0,0 +1,7 @@
+{ %fail }
+
+var
+  s: string;
+begin
+  writestr(s);
+end.

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.

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.