1 /*-
2 * Copyright (c) 1980 The Regents of the University of California.
3 * All rights reserved.
4 *
5 * %sccs.include.proprietary.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)close.c 5.4 (Berkeley) 04/12/91";
10 #endif /* not lint */
11
12 /*
13 * f_clos(): f77 file close
14 * t_runc(): truncation
15 * f_exit(): I/O library exit routines
16 */
17
18 #include "fio.h"
19
20 static char FROM_OPEN[] = "\2";
21 static char clse[] = "close";
22
f_clos(a)23 f_clos(a) cllist *a;
24 { unit *b;
25 int n;
26
27 lfname = NULL;
28 elist = NO;
29 external = YES;
30 errflag = a->cerr;
31 lunit = a->cunit;
32 if(not_legal(lunit)) return(OK);
33 if(lunit==STDERR && (!a->csta || *a->csta != FROM_OPEN[0]))
34 err(errflag,F_ERUNIT,"can't close stderr");
35 b= &units[lunit];
36 if(!b->ufd) return(OK);
37 if(a->csta && *a->csta != FROM_OPEN[0])
38 switch(lcase(*a->csta))
39 {
40 delete:
41 case 'd':
42 fclose(b->ufd);
43 if(b->ufnm) unlink(b->ufnm); /*SYSDEP*/
44 break;
45 default:
46 keep:
47 case 'k':
48 if(b->uwrt && (n=t_runc(b,errflag,clse))) return(n);
49 fclose(b->ufd);
50 break;
51 }
52 else if(b->uscrtch) goto delete;
53 else goto keep;
54 if(b->ufnm) free(b->ufnm);
55 b->ufnm=NULL;
56 b->ufd=NULL;
57 return(OK);
58 }
59
f_exit()60 f_exit()
61 {
62 ftnint lu, dofirst = YES;
63 cllist xx;
64 xx.cerr=1;
65 xx.csta=FROM_OPEN;
66 for(lu=STDOUT; (dofirst || lu!=STDOUT); lu = ++lu % MXUNIT)
67 {
68 xx.cunit=lu;
69 f_clos(&xx);
70 dofirst = NO;
71 }
72 }
73
t_runc(b,flg,str)74 t_runc (b, flg, str)
75 unit *b;
76 ioflag flg;
77 char *str;
78 {
79 long loc;
80
81 if (b->uwrt)
82 fflush (b->ufd);
83 if (b->url || !b->useek || !b->ufnm)
84 return (OK); /* don't truncate direct access files, etc. */
85 loc = ftell (b->ufd);
86 if (truncate (b->ufnm, loc) != 0)
87 err (flg, errno, str)
88 if (b->uwrt && ! nowreading(b))
89 err (flg, errno, str)
90 return (OK);
91 }
92