![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fsplit.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / fsplit|
Return to fsplit.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / fsplit |
1.1 root 1: #include <ctype.h>
2: #include <stdio.h>
3: #include <sys/types.h>
4: #include <sys/stat.h>
5:
6: /*
7: * usage: fsplit [-e efile] ... [file]
8: *
9: * split single file containing source for several fortran programs
10: * and/or subprograms into files each containing one
11: * subprogram unit.
12: * each separate file will be named using the corresponding subroutine,
13: * function, block data or program name if one is found; otherwise
14: * the name will be of the form mainNNN.f or blkdtaNNN.f .
15: * If a file of that name exists, it is saved in a name of the
16: * form zzz000.f .
17: * If -e option is used, then only those subprograms named in the -e
18: * option are split off; e.g.:
19: * fsplit -esub1 -e sub2 prog.f
20: * isolates sub1 and sub2 in sub1.f and sub2.f. The space
21: * after -e is optional.
22: *
23: * Modified Feb., 1983 by Jerry Berkman, Computing Services, U.C. Berkeley.
24: * - added comments
25: * - more function types: double complex, character*(*), etc.
26: * - fixed minor bugs
27: * - instead of all unnamed going into zNNN.f, put mains in
28: * mainNNN.f, block datas in blkdtaNNN.f, dups in zzzNNN.f .
29: */
30:
31: #define BSZ 512
32: char buf[BSZ];
33: FILE *ifp;
34: char x[]="zzz000.f",
35: mainp[]="main000.f",
36: blkp[]="blkdta000.f";
37: char *look(), *skiplab(), *functs();
38:
39: #define TRUE 1
40: #define FALSE 0
41: int extr = FALSE,
42: extrknt = -1,
43: extrfnd[100];
44: char extrbuf[1000],
45: *extrnames[100];
46: struct stat sbuf;
47:
48: #define trim(p) while (*p == ' ' || *p == '\t') p++
49:
50: main(argc, argv)
51: char **argv;
52: {
53: register FILE *ofp; /* output file */
54: register rv; /* 1 if got card in output file, 0 otherwise */
55: register char *ptr;
56: int nflag, /* 1 if got name of subprog., 0 otherwise */
57: retval,
58: i;
59: char name[20],
60: *extrptr = extrbuf;
61:
62: /* scan -e options */
63: while ( argc > 1 && argv[1][0] == '-' && argv[1][1] == 'e') {
64: extr = TRUE;
65: ptr = argv[1] + 2;
66: if(!*ptr) {
67: argc--;
68: argv++;
69: if(argc <= 1) badparms();
70: ptr = argv[1];
71: }
72: extrknt = extrknt + 1;
73: extrnames[extrknt] = extrptr;
74: extrfnd[extrknt] = FALSE;
75: while(*ptr) *extrptr++ = *ptr++;
76: *extrptr++ = 0;
77: argc--;
78: argv++;
79: }
80:
81: if (argc > 2)
82: badparms();
83: else if (argc == 2) {
84: if ((ifp = fopen(argv[1], "r")) == NULL) {
85: fprintf(stderr, "fsplit: cannot open %s\n", argv[1]);
86: exit(1);
87: }
88: }
89: else
90: ifp = stdin;
91: for(;;) {
92: /* look for a temp file that doesn't correspond to an existing file */
93: get_name(x, 3);
94: ofp = fopen(x, "w");
95: nflag = 0;
96: rv = 0;
97: while (getline() > 0) {
98: rv = 1;
99: fprintf(ofp, "%s", buf);
100: if (lend()) /* look for an 'end' statement */
101: break;
102: if (nflag == 0) /* if no name yet, try and find one */
103: nflag = lname(name);
104: }
105: fclose(ofp);
106: if (rv == 0) { /* no lines in file, forget the file */
107: unlink(x);
108: retval = 0;
109: for ( i = 0; i <= extrknt; i++ )
110: if(!extrfnd[i]) {
111: retval = 1;
112: fprintf( stderr, "fsplit: %s not found\n",
113: extrnames[i]);
114: }
115: exit( retval );
116: }
117: if (nflag) { /* rename the file */
118: if(saveit(name)) {
119: if (stat(name, &sbuf) < 0 ) {
120: link(x, name);
121: unlink(x);
122: printf("%s\n", name);
123: continue;
124: } else if (strcmp(name, x) == 0) {
125: printf("%s\n", x);
126: continue;
127: }
128: printf("%s already exists, put in %s\n", name, x);
129: continue;
130: } else
131: unlink(x);
132: continue;
133: }
134: if(!extr)
135: printf("%s\n", x);
136: else
137: unlink(x);
138: }
139: }
140:
141: badparms()
142: {
143: fprintf(stderr, "fsplit: usage: fsplit [-e efile] ... [file] \n");
144: exit(1);
145: }
146:
147: saveit(name)
148: char *name;
149: {
150: int i;
151: char fname[50],
152: *fptr = fname;
153:
154: if(!extr) return(1);
155: while(*name) *fptr++ = *name++;
156: *--fptr = 0;
157: *--fptr = 0;
158: for ( i=0 ; i<=extrknt; i++ )
159: if( strcmp(fname, extrnames[i]) == 0 ) {
160: extrfnd[i] = TRUE;
161: return(1);
162: }
163: return(0);
164: }
165:
166: get_name(name, letters)
167: char *name;
168: int letters;
169: {
170: register char *ptr;
171:
172: while (stat(name, &sbuf) >= 0) {
173: for (ptr = name + letters + 2; ptr >= name + letters; ptr--) {
174: (*ptr)++;
175: if (*ptr <= '9')
176: break;
177: *ptr = '0';
178: }
179: if(ptr < name + letters) {
180: fprintf( stderr, "fsplit: ran out of file names\n");
181: exit(1);
182: }
183: }
184: }
185:
186: getline()
187: {
188: register char *ptr;
189:
190: for (ptr = buf; ptr < &buf[BSZ]; ) {
191: *ptr = getc(ifp);
192: if (feof(ifp))
193: return (-1);
194: if (*ptr++ == '\n') {
195: *ptr = 0;
196: return (1);
197: }
198: }
199: while (getc(ifp) != '\n' && feof(ifp) == 0) ;
200: fprintf(stderr, "line truncated to %d characters\n", BSZ);
201: return (1);
202: }
203:
204: /* return 1 for 'end' alone on card (up to col. 72), 0 otherwise */
205: lend()
206: {
207: register char *p;
208:
209: if ((p = skiplab(buf)) == 0)
210: return (0);
211: trim(p);
212: if (*p != 'e' && *p != 'E') return(0);
213: p++;
214: trim(p);
215: if (*p != 'n' && *p != 'N') return(0);
216: p++;
217: trim(p);
218: if (*p != 'd' && *p != 'D') return(0);
219: p++;
220: trim(p);
221: if (p - buf >= 72 || *p == '\n')
222: return (1);
223: return (0);
224: }
225:
226: /* check for keywords for subprograms
227: return 0 if comment card, 1 if found
228: name and put in arg string. invent name for unnamed
229: block datas and main programs. */
230: lname(s)
231: char *s;
232: {
233: # define LINESIZE 80
234: register char *ptr, *p, *sptr;
235: char line[LINESIZE], *iptr = line;
236:
237: /* first check for comment cards */
238: if(buf[0] == 'c' || buf[0] == 'C' || buf[0] == '*') return(0);
239: ptr = buf;
240: while (*ptr == ' ' || *ptr == '\t') ptr++;
241: if(*ptr == '\n') return(0);
242:
243:
244: ptr = skiplab(buf);
245:
246: /* copy to buffer and converting to lower case */
247: p = ptr;
248: while (*p && p <= &buf[71] ) {
249: *iptr = isupper(*p) ? tolower(*p) : *p;
250: iptr++;
251: p++;
252: }
253: *iptr = '\n';
254:
255: if ((ptr = look(line, "subroutine")) != 0 ||
256: (ptr = look(line, "function")) != 0 ||
257: (ptr = functs(line)) != 0) {
258: if(scan_name(s, ptr)) return(1);
259: strcpy( s, x);
260: } else if((ptr = look(line, "program")) != 0) {
261: if(scan_name(s, ptr)) return(1);
262: get_name( mainp, 4);
263: strcpy( s, mainp);
264: } else if((ptr = look(line, "blockdata")) != 0) {
265: if(scan_name(s, ptr)) return(1);
266: get_name( blkp, 6);
267: strcpy( s, blkp);
268: } else if((ptr = functs(line)) != 0) {
269: if(scan_name(s, ptr)) return(1);
270: strcpy( s, x);
271: } else {
272: get_name( mainp, 4);
273: strcpy( s, mainp);
274: }
275: return(1);
276: }
277:
278:
279: scan_name(s, ptr)
280: char *s, *ptr;
281: {
282: char *sptr;
283:
284: /* scan off the name */
285: trim(ptr);
286: sptr = s;
287: while (*ptr != '(' && *ptr != '\n') {
288: if (*ptr != ' ' && *ptr != '\t')
289: *sptr++ = *ptr;
290: ptr++;
291: }
292:
293: if (sptr == s) return(0);
294:
295: *sptr++ = '.';
296: *sptr++ = 'f';
297: *sptr++ = 0;
298: }
299:
300: char *functs(p)
301: char *p;
302: {
303: register char *ptr;
304:
305: /* look for typed functions such as: real*8 function,
306: character*16 function, character*(*) function */
307:
308: if((ptr = look(p,"character")) != 0 ||
309: (ptr = look(p,"logical")) != 0 ||
310: (ptr = look(p,"real")) != 0 ||
311: (ptr = look(p,"integer")) != 0 ||
312: (ptr = look(p,"doubleprecision")) != 0 ||
313: (ptr = look(p,"complex")) != 0 ||
314: (ptr = look(p,"doublecomplex")) != 0 ) {
315: while ( *ptr == ' ' || *ptr == '\t' || *ptr == '*'
316: || (*ptr >= '0' && *ptr <= '9')
317: || *ptr == '(' || *ptr == ')') ptr++;
318: ptr = look(ptr,"function");
319: return(ptr);
320: }
321: else
322: return(0);
323: }
324:
325: /* if first 6 col. blank, return ptr to col. 7,
326: if blanks and then tab, return ptr after tab,
327: else return 0 (labelled statement, comment or continuation */
328: char *skiplab(p)
329: char *p;
330: {
331: register char *ptr;
332:
333: for (ptr = p; ptr < &p[6]; ptr++) {
334: if (*ptr == ' ')
335: continue;
336: if (*ptr == '\t') {
337: ptr++;
338: break;
339: }
340: return (0);
341: }
342: return (ptr);
343: }
344:
345: /* return 0 if m doesn't match initial part of s;
346: otherwise return ptr to next char after m in s */
347: char *look(s, m)
348: char *s, *m;
349: {
350: register char *sp, *mp;
351:
352: sp = s; mp = m;
353: while (*mp) {
354: trim(sp);
355: if (*sp++ != *mp++)
356: return (0);
357: }
358: return (sp);
359: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.