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