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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [io/] [intrinsics.c] - Blame information for rev 733

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
/* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
2
   FTELL, TTYNAM and ISATTY intrinsics.
3
   Copyright (C) 2005, 2007, 2009, 2010, 2011 Free Software
4
   Foundation, Inc.
5
 
6
This file is part of the GNU Fortran runtime library (libgfortran).
7
 
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
 
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
 
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
 
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
 
27
#include "io.h"
28
#include "fbuf.h"
29
#include "unix.h"
30
#include <stdlib.h>
31
#include <string.h>
32
 
33
 
34
static const int five = 5;
35
static const int six = 6;
36
 
37
extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
38
export_proto_np(PREFIX(fgetc));
39
 
40
int
41
PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
42
{
43
  int ret;
44
  gfc_unit * u = find_unit (*unit);
45
 
46
  if (u == NULL)
47
    return -1;
48
 
49
  fbuf_reset (u);
50
  if (u->mode == WRITING)
51
    {
52
      sflush (u->s);
53
      u->mode = READING;
54
    }
55
 
56
  memset (c, ' ', c_len);
57
  ret = sread (u->s, c, 1);
58
  unlock_unit (u);
59
 
60
  if (ret < 0)
61
    return ret;
62
 
63
  if (ret != 1)
64
    return -1;
65
  else
66
    return 0;
67
}
68
 
69
 
70
#define FGETC_SUB(kind) \
71
  extern void fgetc_i ## kind ## _sub \
72
    (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
73
  export_proto(fgetc_i ## kind ## _sub); \
74
  void fgetc_i ## kind ## _sub \
75
  (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
76
    { if (st != NULL) \
77
        *st = PREFIX(fgetc) (unit, c, c_len); \
78
      else \
79
        PREFIX(fgetc) (unit, c, c_len); }
80
 
81
FGETC_SUB(1)
82
FGETC_SUB(2)
83
FGETC_SUB(4)
84
FGETC_SUB(8)
85
 
86
 
87
extern int PREFIX(fget) (char *, gfc_charlen_type);
88
export_proto_np(PREFIX(fget));
89
 
90
int
91
PREFIX(fget) (char * c, gfc_charlen_type c_len)
92
{
93
  return PREFIX(fgetc) (&five, c, c_len);
94
}
95
 
96
 
97
#define FGET_SUB(kind) \
98
  extern void fget_i ## kind ## _sub \
99
    (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
100
  export_proto(fget_i ## kind ## _sub); \
101
  void fget_i ## kind ## _sub \
102
  (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
103
    { if (st != NULL) \
104
        *st = PREFIX(fgetc) (&five, c, c_len); \
105
      else \
106
        PREFIX(fgetc) (&five, c, c_len); }
107
 
108
FGET_SUB(1)
109
FGET_SUB(2)
110
FGET_SUB(4)
111
FGET_SUB(8)
112
 
113
 
114
 
115
extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type);
116
export_proto_np(PREFIX(fputc));
117
 
118
int
119
PREFIX(fputc) (const int * unit, char * c,
120
               gfc_charlen_type c_len __attribute__((unused)))
121
{
122
  ssize_t s;
123
  gfc_unit * u = find_unit (*unit);
124
 
125
  if (u == NULL)
126
    return -1;
127
 
128
  fbuf_reset (u);
129
  if (u->mode == READING)
130
    {
131
      sflush (u->s);
132
      u->mode = WRITING;
133
    }
134
 
135
  s = swrite (u->s, c, 1);
136
  unlock_unit (u);
137
  if (s < 0)
138
    return -1;
139
  return 0;
140
}
141
 
142
 
143
#define FPUTC_SUB(kind) \
144
  extern void fputc_i ## kind ## _sub \
145
    (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
146
  export_proto(fputc_i ## kind ## _sub); \
147
  void fputc_i ## kind ## _sub \
148
  (const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
149
    { if (st != NULL) \
150
        *st = PREFIX(fputc) (unit, c, c_len); \
151
      else \
152
        PREFIX(fputc) (unit, c, c_len); }
153
 
154
FPUTC_SUB(1)
155
FPUTC_SUB(2)
156
FPUTC_SUB(4)
157
FPUTC_SUB(8)
158
 
159
 
160
extern int PREFIX(fput) (char *, gfc_charlen_type);
161
export_proto_np(PREFIX(fput));
162
 
163
int
164
PREFIX(fput) (char * c, gfc_charlen_type c_len)
165
{
166
  return PREFIX(fputc) (&six, c, c_len);
167
}
168
 
169
 
170
#define FPUT_SUB(kind) \
171
  extern void fput_i ## kind ## _sub \
172
    (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
173
  export_proto(fput_i ## kind ## _sub); \
174
  void fput_i ## kind ## _sub \
175
  (char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
176
    { if (st != NULL) \
177
        *st = PREFIX(fputc) (&six, c, c_len); \
178
      else \
179
        PREFIX(fputc) (&six, c, c_len); }
180
 
181
FPUT_SUB(1)
182
FPUT_SUB(2)
183
FPUT_SUB(4)
184
FPUT_SUB(8)
185
 
186
 
187
/* SUBROUTINE FLUSH(UNIT)
188
   INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
189
 
190
extern void flush_i4 (GFC_INTEGER_4 *);
191
export_proto(flush_i4);
192
 
193
void
194
flush_i4 (GFC_INTEGER_4 *unit)
195
{
196
  gfc_unit *us;
197
 
198
  /* flush all streams */
199
  if (unit == NULL)
200
    flush_all_units ();
201
  else
202
    {
203
      us = find_unit (*unit);
204
      if (us != NULL)
205
        {
206
          sflush (us->s);
207
          unlock_unit (us);
208
        }
209
    }
210
}
211
 
212
 
213
extern void flush_i8 (GFC_INTEGER_8 *);
214
export_proto(flush_i8);
215
 
216
void
217
flush_i8 (GFC_INTEGER_8 *unit)
218
{
219
  gfc_unit *us;
220
 
221
  /* flush all streams */
222
  if (unit == NULL)
223
    flush_all_units ();
224
  else
225
    {
226
      us = find_unit (*unit);
227
      if (us != NULL)
228
        {
229
          sflush (us->s);
230
          unlock_unit (us);
231
        }
232
    }
233
}
234
 
235
/* FSEEK intrinsic */
236
 
237
extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
238
export_proto(fseek_sub);
239
 
240
void
241
fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
242
{
243
  gfc_unit * u = find_unit (*unit);
244
  ssize_t result = -1;
245
 
246
  if (u != NULL)
247
    {
248
      result = sseek(u->s, *offset, *whence);
249
 
250
      unlock_unit (u);
251
    }
252
 
253
  if (status)
254
    *status = (result < 0 ? -1 : 0);
255
}
256
 
257
 
258
 
259
/* FTELL intrinsic */
260
 
261
static gfc_offset
262
gf_ftell (int unit)
263
{
264
  gfc_unit * u = find_unit (unit);
265
  if (u == NULL)
266
    return -1;
267
  int pos = fbuf_reset (u);
268
  if (pos != 0)
269
    sseek (u->s, pos, SEEK_CUR);
270
  gfc_offset ret = stell (u->s);
271
  unlock_unit (u);
272
  return ret;
273
}
274
 
275
extern size_t PREFIX(ftell) (int *);
276
export_proto_np(PREFIX(ftell));
277
 
278
size_t
279
PREFIX(ftell) (int * unit)
280
{
281
  return gf_ftell (*unit);
282
}
283
 
284
#define FTELL_SUB(kind) \
285
  extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
286
  export_proto(ftell_i ## kind ## _sub); \
287
  void \
288
  ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
289
  { \
290
    *offset = gf_ftell (*unit);                 \
291
  }
292
 
293
FTELL_SUB(1)
294
FTELL_SUB(2)
295
FTELL_SUB(4)
296
FTELL_SUB(8)
297
 
298
 
299
 
300
/* LOGICAL FUNCTION ISATTY(UNIT)
301
   INTEGER, INTENT(IN) :: UNIT */
302
 
303
extern GFC_LOGICAL_4 isatty_l4 (int *);
304
export_proto(isatty_l4);
305
 
306
GFC_LOGICAL_4
307
isatty_l4 (int *unit)
308
{
309
  gfc_unit *u;
310
  GFC_LOGICAL_4 ret = 0;
311
 
312
  u = find_unit (*unit);
313
  if (u != NULL)
314
    {
315
      ret = (GFC_LOGICAL_4) stream_isatty (u->s);
316
      unlock_unit (u);
317
    }
318
  return ret;
319
}
320
 
321
 
322
extern GFC_LOGICAL_8 isatty_l8 (int *);
323
export_proto(isatty_l8);
324
 
325
GFC_LOGICAL_8
326
isatty_l8 (int *unit)
327
{
328
  gfc_unit *u;
329
  GFC_LOGICAL_8 ret = 0;
330
 
331
  u = find_unit (*unit);
332
  if (u != NULL)
333
    {
334
      ret = (GFC_LOGICAL_8) stream_isatty (u->s);
335
      unlock_unit (u);
336
    }
337
  return ret;
338
}
339
 
340
 
341
/* SUBROUTINE TTYNAM(UNIT,NAME)
342
   INTEGER,SCALAR,INTENT(IN) :: UNIT
343
   CHARACTER,SCALAR,INTENT(OUT) :: NAME */
344
 
345
extern void ttynam_sub (int *, char *, gfc_charlen_type);
346
export_proto(ttynam_sub);
347
 
348
void
349
ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
350
{
351
  gfc_unit *u;
352
  int nlen;
353
  int err = 1;
354
 
355
  u = find_unit (*unit);
356
  if (u != NULL)
357
    {
358
      err = stream_ttyname (u->s, name, name_len);
359
      if (err == 0)
360
        {
361
          nlen = strlen (name);
362
          memset (&name[nlen], ' ', name_len - nlen);
363
        }
364
 
365
      unlock_unit (u);
366
    }
367
  if (err != 0)
368
    memset (name, ' ', name_len);
369
}
370
 
371
 
372
extern void ttynam (char **, gfc_charlen_type *, int);
373
export_proto(ttynam);
374
 
375
void
376
ttynam (char ** name, gfc_charlen_type * name_len, int unit)
377
{
378
  gfc_unit *u;
379
 
380
  u = find_unit (unit);
381
  if (u != NULL)
382
    {
383
      *name = get_mem (TTY_NAME_MAX);
384
      int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
385
      if (err == 0)
386
        {
387
          *name_len = strlen (*name);
388
          unlock_unit (u);
389
          return;
390
        }
391
      free (*name);
392
      unlock_unit (u);
393
    }
394
 
395
  *name_len = 0;
396
  *name = NULL;
397
}

powered by: WebSVN 2.1.0

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