OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

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

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
  st = fgetc(10,s)
11
  if ((st /= 0) .or. (s /= "a    ")) call abort
12
  st = fgetc(10,s)
13
  close(10)
14
 
15
  open(10,status="scratch")
16
  s = "12345"
17
  st = fputc(10,s)
18
  if (st /= 0) call abort
19
  st = fputc(10,"2")
20
  if (st /= 0) call abort
21
  st = fputc(10,"3 ")
22
  if (st /= 0) call abort
23
  rewind(10)
24
  st = fgetc(10,s)
25
  if (s(1:1) /= "1") call abort
26
  st = fgetc(10,s)
27
  if (s(1:1) /= "2") call abort
28
  st = fgetc(10,s)
29
  if ((s(1:1) /= "3") .or. (st /= 0)) call abort
30
  st = fgetc(10,s)
31
  if (st /= -1) call abort
32
  close (10)
33
 
34
! FGETC and FPUTC on units not opened should not work
35
  st = fgetc(12,s)
36
  if (st /= -1) call abort
37
  st = fputc(12,s)
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.