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.