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 * Redistribution and use in source and binary forms, with or without
9 * modification, are permitted provided that the following conditions
10 * are met:
11 * 1. Redistributions of source code must retain the above copyright
12 * notice, this list of conditions and the following disclaimer.
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 * 3. Neither the name of the University nor the names of its contributors
17 * may be used to endorse or promote products derived from this software
18 * without specific prior written permission.
19 *
20 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
21 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
24 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
26 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
27 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
28 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
29 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
30 * SUCH DAMAGE.
31 */
32
33 #include <sys/cdefs.h>
34 #ifndef lint
35 __COPYRIGHT("@(#) Copyright (c) 1983, 1993\
36 The Regents of the University of California. All rights reserved.");
37 #endif /* not lint */
38
39 #ifndef lint
40 #if 0
41 static char sccsid[] = "from: @(#)fsplit.c 8.1 (Berkeley) 6/6/93";
42 #else
43 __RCSID("$NetBSD: fsplit.c,v 1.30 2015/06/16 22:54:10 christos Exp $");
44 #endif
45 #endif /* not lint */
46
47 #include <sys/types.h>
48 #include <sys/stat.h>
49
50 #include <assert.h>
51 #include <ctype.h>
52 #include <err.h>
53 #include <stdbool.h>
54 #include <stdio.h>
55 #include <stdlib.h>
56 #include <string.h>
57 #include <unistd.h>
58
59 /*
60 * usage: fsplit [-e efile] ... [file]
61 *
62 * split single file containing source for several fortran programs
63 * and/or subprograms into files each containing one
64 * subprogram unit.
65 * each separate file will be named using the corresponding subroutine,
66 * function, block data or program name if one is found; otherwise
67 * the name will be of the form mainNNN.f or blkdtaNNN.f .
68 * If a file of that name exists, it is saved in a name of the
69 * form zzz000.f .
70 * If -e option is used, then only those subprograms named in the -e
71 * option are split off; e.g.:
72 * fsplit -esub1 -e sub2 prog.f
73 * isolates sub1 and sub2 in sub1.f and sub2.f. The space
74 * after -e is optional.
75 *
76 * Modified Feb., 1983 by Jerry Berkman, Computing Services, U.C. Berkeley.
77 * - added comments
78 * - more function types: double complex, character*(*), etc.
79 * - fixed minor bugs
80 * - instead of all unnamed going into zNNN.f, put mains in
81 * mainNNN.f, block datas in blkdtaNNN.f, dups in zzzNNN.f .
82 */
83
84 #define BSZ 512
85 static char buf[BSZ];
86 static FILE *ifp;
87
88 static char x[] = "zzz000.f";
89 static char mainp[] = "main000.f";
90 static char blkp[] = "blkdta000.f";
91
92 __dead static void badparms(void);
93 static const char *functs(const char *);
94 static int get_line(void);
95 static void get_name(char *, int);
96 static int lend(void);
97 static int lname(char *, size_t);
98 static const char *look(const char *, const char *);
99 static int saveit(const char *);
100 static int scan_name(char *, size_t, const char *);
101 static const char *skiplab(const char *);
102 static const char *skipws(const char *);
103
104 struct extract {
105 bool found;
106 char *name;
107 };
108
109 #define MAXEXTONLY 100
110 static struct extract extonly[MAXEXTONLY];
111 static int numextonly = 0;
112
113 int
main(int argc,char ** argv)114 main(int argc, char **argv)
115 {
116 FILE *ofp; /* output file */
117 int rv; /* 1 if got card in output file, 0 otherwise */
118 int nflag; /* 1 if got name of subprog., 0 otherwise */
119 int retval, i, ch;
120 char name[80];
121
122 while ((ch = getopt(argc, argv, "e:")) != -1) {
123 switch (ch) {
124 case 'e':
125 if (numextonly >= MAXEXTONLY) {
126 errx(1, "Too many -e options");
127 }
128 extonly[numextonly].name = optarg;
129 extonly[numextonly].found = false;
130 numextonly++;
131 break;
132 default:
133 badparms();
134 break;
135 }
136 }
137
138 if (argc > 2) {
139 badparms();
140 } else if (argc == 2) {
141 if ((ifp = fopen(argv[1], "r")) == NULL) {
142 err(1, "%s", argv[1]);
143 }
144 } else {
145 ifp = stdin;
146 }
147
148 for (;;) {
149 /*
150 * Look for a temp file that doesn't correspond to an
151 * existing file.
152 */
153
154 get_name(x, 3);
155 ofp = fopen(x, "w");
156 if (ofp == NULL) {
157 err(1, "%s", x);
158 }
159 nflag = 0;
160 rv = 0;
161 while (get_line() > 0) {
162 rv = 1;
163 fprintf(ofp, "%s", buf);
164 /* look for an 'end' statement */
165 if (lend()) {
166 break;
167 }
168 /* if no name yet, try and find one */
169 if (nflag == 0) {
170 nflag = lname(name, sizeof(name));
171 }
172 }
173 fclose(ofp);
174 if (rv == 0) {
175 /* no lines in file, forget the file */
176 unlink(x);
177 retval = 0;
178 for (i = 0; i < numextonly; i++) {
179 if (!extonly[i].found) {
180 retval = 1;
181 warnx("%s not found", extonly[i].name);
182 }
183 }
184 exit(retval);
185 }
186 if (nflag) {
187 /* rename the file */
188 if (saveit(name)) {
189 struct stat sbuf;
190
191 if (stat(name, &sbuf) < 0) {
192 if (rename(x, name) < 0) {
193 warn("%s: rename", x);
194 printf("%s left in %s\n",
195 name, x);
196 } else {
197 printf("%s\n", name);
198 }
199 continue;
200 } else if (strcmp(name, x) == 0) {
201 printf("%s\n", x);
202 continue;
203 }
204 printf("%s already exists, put in %s\n",
205 name, x);
206 continue;
207 } else {
208 unlink(x);
209 continue;
210 }
211 }
212 if (numextonly == 0) {
213 printf("%s\n", x);
214 } else {
215 unlink(x);
216 }
217 }
218 }
219
220 static void
badparms(void)221 badparms(void)
222 {
223 err(1, "Usage: fsplit [-e efile] ... [file]");
224 }
225
226 static int
saveit(const char * name)227 saveit(const char *name)
228 {
229 int i;
230 char fname[50];
231 size_t fnamelen;
232
233 if (numextonly == 0) {
234 return 1;
235 }
236 strlcpy(fname, name, sizeof(fname));
237 fnamelen = strlen(fname);
238 /* Guaranteed by scan_name. */
239 assert(fnamelen > 2);
240 assert(fname[fnamelen-2] == '.');
241 assert(fname[fnamelen-1] == 'f');
242 fname[fnamelen-2] = '\0';
243
244 for (i = 0; i < numextonly; i++) {
245 if (strcmp(fname, extonly[i].name) == 0) {
246 extonly[i].found = true;
247 return 1;
248 }
249 }
250 return 0;
251 }
252
253 static void
get_name(char * name,int letters)254 get_name(char *name, int letters)
255 {
256 struct stat sbuf;
257 char *ptr;
258
259 while (stat(name, &sbuf) >= 0) {
260 for (ptr = name + letters + 2; ptr >= name + letters; ptr--) {
261 (*ptr)++;
262 if (*ptr <= '9')
263 break;
264 *ptr = '0';
265 }
266 if (ptr < name + letters) {
267 errx(1, "Ran out of file names.");
268 }
269 }
270 }
271
272 static int
get_line(void)273 get_line(void)
274 {
275 char *ptr;
276
277 for (ptr = buf; ptr < &buf[BSZ]; ) {
278 *ptr = getc(ifp);
279 if (feof(ifp))
280 return -1;
281 if (*ptr++ == '\n') {
282 *ptr = '\0';
283 return 1;
284 }
285 }
286 while (getc(ifp) != '\n' && feof(ifp) == 0) {
287 /* nothing */
288 }
289 warnx("Line truncated to %d characters.", BSZ);
290 return 1;
291 }
292
293 /*
294 * Return 1 for 'end' alone on card (up to col. 72), 0 otherwise.
295 */
296 static int
lend(void)297 lend(void)
298 {
299 const char *p;
300
301 if ((p = skiplab(buf)) == 0) {
302 return 0;
303 }
304 p = skipws(p);
305 if (*p != 'e' && *p != 'E') {
306 return 0;
307 }
308 p++;
309 p = skipws(p);
310 if (*p != 'n' && *p != 'N') {
311 return 0;
312 }
313 p++;
314 p = skipws(p);
315 if (*p != 'd' && *p != 'D') {
316 return 0;
317 }
318 p++;
319 p = skipws(p);
320 if (p - buf >= 72 || *p == '\n') {
321 return 1;
322 }
323 return 0;
324 }
325
326 /*
327 * check for keywords for subprograms
328 * return 0 if comment card, 1 if found
329 * name and put in arg string. invent name for unnamed
330 * block datas and main programs.
331 */
332 static int
lname(char * s,size_t l)333 lname(char *s, size_t l)
334 {
335 #define LINESIZE 80
336 const char *ptr, *p;
337 char line[LINESIZE], *iptr = line;
338
339 /* first check for comment cards */
340 if (buf[0] == 'c' || buf[0] == 'C' || buf[0] == '*') {
341 return 0;
342 }
343 ptr = skipws(buf);
344 if (*ptr == '\n') {
345 return 0;
346 }
347
348 ptr = skiplab(buf);
349 if (ptr == NULL) {
350 return 0;
351 }
352
353 /* copy to buffer and converting to lower case */
354 p = ptr;
355 while (*p && p <= &buf[71] ) {
356 *iptr = tolower((unsigned char)*p);
357 iptr++;
358 p++;
359 }
360 *iptr = '\n';
361
362 if ((ptr = look(line, "subroutine")) != NULL ||
363 (ptr = look(line, "function")) != NULL ||
364 (ptr = functs(line)) != NULL) {
365 if (scan_name(s, l, ptr)) {
366 return 1;
367 }
368 strlcpy(s, x, l);
369 } else if ((ptr = look(line, "program")) != NULL) {
370 if (scan_name(s, l, ptr)) {
371 return 1;
372 }
373 get_name(mainp, 4);
374 strlcpy(s, mainp, l);
375 } else if ((ptr = look(line, "blockdata")) != NULL) {
376 if (scan_name(s, l, ptr)) {
377 return 1;
378 }
379 get_name(blkp, 6);
380 strlcpy(s, blkp, l);
381 } else if ((ptr = functs(line)) != NULL) {
382 if (scan_name(s, l, ptr)) {
383 return 1;
384 }
385 strlcpy(s, x, l);
386 } else {
387 get_name(mainp, 4);
388 strlcpy(s, mainp, l);
389 }
390 return 1;
391 }
392
393 static int
scan_name(char * s,size_t smax,const char * ptr)394 scan_name(char *s, size_t smax, const char *ptr)
395 {
396 char *sptr;
397 size_t sptrmax;
398
399 /* scan off the name */
400 ptr = skipws(ptr);
401 sptr = s;
402 sptrmax = smax - 3;
403 while (*ptr != '(' && *ptr != '\n') {
404 if (*ptr != ' ' && *ptr != '\t' && *ptr != '/') {
405 if (sptrmax == 0) {
406 /* Not sure this is the right thing, so warn */
407 warnx("Output name too long; truncated");
408 break;
409 }
410 *sptr++ = *ptr;
411 sptrmax--;
412 }
413 ptr++;
414 }
415
416 if (sptr == s) {
417 return 0;
418 }
419
420 *sptr++ = '.';
421 *sptr++ = 'f';
422 *sptr++ = '\0';
423 return 1;
424 }
425
426 /*
427 * look for typed functions such as: real*8 function,
428 * character*16 function, character*(*) function
429 */
430 static const char *
functs(const char * p)431 functs(const char *p)
432 {
433 const char *ptr;
434
435 if ((ptr = look(p, "character")) != NULL ||
436 (ptr = look(p, "logical")) != NULL ||
437 (ptr = look(p, "real")) != NULL ||
438 (ptr = look(p, "integer")) != NULL ||
439 (ptr = look(p, "doubleprecision")) != NULL ||
440 (ptr = look(p, "complex")) != NULL ||
441 (ptr = look(p, "doublecomplex")) != NULL) {
442 while (*ptr == ' ' || *ptr == '\t' || *ptr == '*'
443 || (*ptr >= '0' && *ptr <= '9')
444 || *ptr == '(' || *ptr == ')') {
445 ptr++;
446 }
447 ptr = look(ptr, "function");
448 return ptr;
449 }
450 else {
451 return NULL;
452 }
453 }
454
455 /*
456 * if first 6 col. blank, return ptr to col. 7,
457 * if blanks and then tab, return ptr after tab,
458 * else return NULL (labelled statement, comment or continuation)
459 */
460 static const char *
skiplab(const char * p)461 skiplab(const char *p)
462 {
463 const char *ptr;
464
465 for (ptr = p; ptr < &p[6]; ptr++) {
466 if (*ptr == ' ')
467 continue;
468 if (*ptr == '\t') {
469 ptr++;
470 break;
471 }
472 return NULL;
473 }
474 return ptr;
475 }
476
477 /*
478 * return NULL if m doesn't match initial part of s;
479 * otherwise return ptr to next char after m in s
480 */
481 static const char *
look(const char * s,const char * m)482 look(const char *s, const char *m)
483 {
484 const char *sp, *mp;
485
486 sp = s; mp = m;
487 while (*mp) {
488 sp = skipws(sp);
489 if (*sp++ != *mp++)
490 return NULL;
491 }
492 return sp;
493 }
494
495 static const char *
skipws(const char * p)496 skipws(const char *p)
497 {
498 while (*p == ' ' || *p == '\t') {
499 p++;
500 }
501 return p;
502 }
503