OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.2.2/] [gcc/] [testsuite/] [gfortran.dg/] [fgetc_1.f90] - Blame information for rev 149

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn 
! Testcase for the FGETC and FPUTC intrinsics
2 
! { dg-do run }
3 
  character(len=5) s
4 
  integer st
5 
 
6 
  s = "12345"
7 
  open(10,status="scratch")
8 
  write(10,"(A)") "abcde"
9 
  rewind(10)
10 
  call fgetc(10,s,st)
11 
  if ((st /= 0) .or. (s /= "a    ")) call abort
12 
  call fgetc(10,s,st)
13 
  close(10)
14 
 
15 
  open(10,status="scratch")
16 
  s = "12345"
17 
  call fputc(10,s,st)
18 
  if (st /= 0) call abort
19 
  call fputc(10,"2",st)
20 
  if (st /= 0) call abort
21 
  call fputc(10,"3 ",st)
22 
  if (st /= 0) call abort
23 
  rewind(10)
24 
  call fgetc(10,s)
25 
  if (s(1:1) /= "1") call abort
26 
  call fgetc(10,s)
27 
  if (s(1:1) /= "2") call abort
28 
  call fgetc(10,s,st)
29 
  if ((s(1:1) /= "3") .or. (st /= 0)) call abort
30 
  call fgetc(10,s,st)
31 
  if (st /= -1) call abort
32 
  close (10)
33 
 
34 
! FGETC and FPUTC on units not opened should not work
35 
  call fgetc(12,s,st)
36 
  if (st /= -1) call abort
37 
  call fputc(12,s,st)
38 
  if (st /= -1) call abort
39 
  end

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.