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
41static char sccsid[] = "from: @(#)fsplit.c	8.1 (Berkeley) 6/6/93";
42#else
43__RCSID("$NetBSD: fsplit.c,v 1.29 2013/01/23 20:39:46 riastradh 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
85static char buf[BSZ];
86static FILE *ifp;
87
88static char x[] = "zzz000.f";
89static char mainp[] = "main000.f";
90static char blkp[] = "blkdta000.f";
91
92__dead static void badparms(void);
93static const char *functs(const char *);
94static int get_line(void);
95static void get_name(char *, int);
96static int lend(void);
97static int lname(char *, size_t);
98static const char *look(const char *, const char *);
99static int saveit(const char *);
100static int scan_name(char *, size_t, const char *);
101static const char *skiplab(const char *);
102static const char *skipws(const char *);
103
104struct extract {
105	bool found;
106	char *name;
107};
108
109#define MAXEXTONLY 100
110static struct extract extonly[MAXEXTONLY];
111static int numextonly = 0;
112
113int
114main(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
220static void
221badparms(void)
222{
223	err(1, "Usage: fsplit [-e efile] ... [file]");
224}
225
226static int
227saveit(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
253static void
254get_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
272static int
273get_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 */
296static int
297lend(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 */
332static int
333lname(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
393static int
394scan_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 */
430static const char *
431functs(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 */
460static const char *
461skiplab(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 */
481static const char *
482look(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
495static const char *
496skipws(const char *p)
497{
498	while (*p == ' ' || *p == '\t') {
499		p++;
500	}
501	return p;
502}
503