path: root/usr.bin/fsplit/fsplit.c

/*	$OpenBSD: fsplit.c,v 1.8 2001/11/19 19:02:14 mpech Exp $	*/

/*
 * Copyright (c) 1983, 1993
 *	The Regents of the University of California.  All rights reserved.
 *
 * This code is derived from software contributed to Berkeley by
 * Asa Romberger and Jerry Berkman.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. All advertising materials mentioning features or use of this software
 *    must display the following acknowledgement:
 *	This product includes software developed by the University of
 *	California, Berkeley and its contributors.
 * 4. Neither the name of the University nor the names of its contributors
 *    may be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

#ifndef lint
static char copyright[] =
"@(#) Copyright (c) 1983, 1993\n\
	The Regents of the University of California.  All rights reserved.\n";
#endif				/* not lint */

#ifndef lint
/*static char sccsid[] = "from: @(#)fsplit.c	8.1 (Berkeley) 6/6/93";*/
static char rcsid[] = "$OpenBSD: fsplit.c,v 1.8 2001/11/19 19:02:14 mpech Exp $";
#endif				/* not lint */

#include <ctype.h>
#include <stdio.h>
#include <unistd.h>
#include <string.h>
#include <stdlib.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/fcntl.h>
#include <err.h>

void badparms __P(());
void get_name __P((char *, int));
int lname __P((char *));
int getline __P((void));
int lend __P((void));
int scan_name __P((char *, char *));
int saveit __P((char *));

/*
 *	usage:		fsplit [-e efile] ... [file]
 *
 *	split single file containing source for several fortran programs
 *		and/or subprograms into files each containing one
 *		subprogram unit.
 *	each separate file will be named using the corresponding subroutine,
 *		function, block data or program name if one is found; otherwise
 *		the name will be of the form mainNNN.f or blkdtaNNN.f .
 *		If a file of that name exists, it is saved in a name of the
 *		form zzz000.f .
 *	If -e option is used, then only those subprograms named in the -e
 *		option are split off; e.g.:
 *			fsplit -esub1 -e sub2 prog.f
 *		isolates sub1 and sub2 in sub1.f and sub2.f.  The space
 *		after -e is optional.
 *
 *	Modified Feb., 1983 by Jerry Berkman, Computing Services, U.C. Berkeley.
 *		- added comments
 *		- more function types: double complex, character*(*), etc.
 *		- fixed minor bugs
 *		- instead of all unnamed going into zNNN.f, put mains in
 *		  mainNNN.f, block datas in blkdtaNNN.f, dups in zzzNNN.f .
 */

#define BSZ 512
char    buf[BSZ];
FILE   *ifp;
char    x[] = "zzz000.f", mainp[] = "main000.f", blkp[] = "blkdta000.f";
char   *look(), *skiplab(), *functs();

#define TRUE 1
#define FALSE 0
int     extr = FALSE, extrknt = -1;
int maxextrknt;

int *extrfnd;
char **extrnames;
struct stat sbuf;

#define trim(p)	while (*p == ' ' || *p == '\t') p++

int
main(argc, argv)
	char  **argv;
{
	FILE *ofp;	/* output file */
	int rv;	/* 1 if got card in output file, 0 otherwise */
	char *ptr;
	int     nflag,		/* 1 if got name of subprog., 0 otherwise */
	        retval, i;
	/* must be as large as max(sizeof(x), sizeof(mainp), sizeof(blockp)) */
	char    name[20];	

	maxextrknt = 100;
	extrnames = malloc(sizeof(char *) * maxextrknt);
	if (extrnames == NULL)
		errx(1, "out of memory");
	/* scan -e options */
	while (argc > 1 && argv[1][0] == '-' && argv[1][1] == 'e') {
		extr = TRUE;
		ptr = argv[1] + 2;
		if (!*ptr) {
			argc--;
			argv++;
			if (argc <= 1)
				badparms();
			ptr = argv[1];
		}
		extrknt = extrknt + 1;
		if (extrknt >= maxextrknt) {
			extrnames = realloc(extrnames, 
			    sizeof(char *) * maxextrknt);
			if (extrnames == NULL)
				errx(1, "too many -e arguments");
		}
		if ((extrnames[extrknt] = strdup(ptr)) == NULL)
			errx(1, "out of memory");
		argc--;
		argv++;
	}

	extrfnd = calloc(extrknt+1, sizeof(int));
	if (extrfnd == NULL)
		errx(1, "out of memory");

	if (argc > 2)
		badparms();
	else
		if (argc == 2) {
			if ((ifp = fopen(argv[1], "r")) == NULL)
				err(1, "%s", argv[1]);
		} else
			ifp = stdin;
	for (;;) {
		int fd;

		/* look for a temp file that doesn't correspond to an existing
		 * file */
		get_name(x, 3);

		fd = open(x, O_CREAT|O_EXCL|O_RDWR, 0666);
		if (fd == -1)
			err(1, "%s", x);
		ofp = fdopen(fd, "w");
		if (ofp == NULL) {
			close(fd);
			unlink(x);
			err(1, "%s", x);
		}
		nflag = 0;
		rv = 0;
		while (getline() > 0) {
			rv = 1;
			fprintf(ofp, "%s", buf);
			if (lend())	/* look for an 'end' statement */
				break;
			if (nflag == 0)	/* if no name yet, try and find one */
				nflag = lname(name);
		}
		fclose(ofp);
		if (rv == 0) {	/* no lines in file, forget the file */
			unlink(x);
			retval = 0;
			for (i = 0; i <= extrknt; i++)
				if (!extrfnd[i]) {
					retval = 1;
					warnx("%s not found", extrnames[i]);
				}
			exit(retval);
		}
		if (nflag) {	/* rename the file */
			if (saveit(name)) {
				if (stat(name, &sbuf) < 0) {
					link(x, name);
					unlink(x);
					printf("%s\n", name);
					continue;
				} else
					if (strcmp(name, x) == 0) {
						printf("%s\n", x);
						continue;
					}
				printf("%s already exists, put in %s\n", name, x);
				continue;
			} else
				unlink(x);
			continue;
		}
		if (!extr)
			printf("%s\n", x);
		else
			unlink(x);
	}
}

void
badparms()
{
	fprintf(stderr, "usage:  fsplit [-e efile] ... [file]\n");
	exit(1);
}

int
saveit(name)
	char   *name;
{
	int     i;
	size_t 	n;

	if (!extr)
		return (1);

	n = strlen(name);
	if (n < 2)
		return (0);

	for (i = 0; i <= extrknt; i++)
		if (strncmp(name, extrnames[i], n - 2) == 0 &&
		extrnames[i][n-2] == '\0') {
			extrfnd[i] = TRUE;
			return (1);
		}
	return (0);
}

void
get_name(name, letters)
	char   *name;
	int     letters;
{
	char *ptr;

	while (stat(name, &sbuf) >= 0) {
		for (ptr = name + letters + 2; ptr >= name + letters; ptr--) {
			(*ptr)++;
			if (*ptr <= '9')
				break;
			*ptr = '0';
		}
		if (ptr < name + letters)
			errx(1, "ran out of file names");
	}
}

int
getline()
{
	char *ptr;

	for (ptr = buf; ptr < &buf[BSZ];) {
		*ptr = getc(ifp);
		if (feof(ifp))
			return (-1);
		if (*ptr++ == '\n') {
			*ptr = 0;
			return (1);
		}
	}
	while (getc(ifp) != '\n' && feof(ifp) == 0);
	warnx("line truncated to %d characters", BSZ);
	return (1);
}
/* return 1 for 'end' alone on card (up to col. 72),  0 otherwise */
int
lend()
{
	char *p;

	if ((p = skiplab(buf)) == 0)
		return (0);
	trim(p);
	if (*p != 'e' && *p != 'E')
		return (0);
	p++;
	trim(p);
	if (*p != 'n' && *p != 'N')
		return (0);
	p++;
	trim(p);
	if (*p != 'd' && *p != 'D')
		return (0);
	p++;
	trim(p);
	if (p - buf >= 72 || *p == '\n')
		return (1);
	return (0);
}
/*		check for keywords for subprograms
		return 0 if comment card, 1 if found
		name and put in arg string. invent name for unnamed
		block datas and main programs.		*/
int
lname(s)
	char   *s;
{
#define LINESIZE 80
	char *ptr, *p;
	char    line[LINESIZE], *iptr = line;

	/* first check for comment cards */
	if (buf[0] == 'c' || buf[0] == 'C' || buf[0] == '*')
		return (0);
	ptr = buf;
	while (*ptr == ' ' || *ptr == '\t')
		ptr++;
	if (*ptr == '\n')
		return (0);


	ptr = skiplab(buf);
	if (ptr == 0)
		return (0);


	/* copy to buffer and converting to lower case */
	p = ptr;
	while (*p && p <= &buf[71]) {
		*iptr = tolower(*p);
		iptr++;
		p++;
	}
	*iptr = '\n';

	if ((ptr = look(line, "subroutine")) != 0 ||
	    (ptr = look(line, "function")) != 0 ||
	    (ptr = functs(line)) != 0) {
		if (scan_name(s, ptr))
			return (1);
		strcpy(s, x);
	} else
		if ((ptr = look(line, "program")) != 0) {
			if (scan_name(s, ptr))
				return (1);
			get_name(mainp, 4);
			strcpy(s, mainp);
		} else
			if ((ptr = look(line, "blockdata")) != 0) {
				if (scan_name(s, ptr))
					return (1);
				get_name(blkp, 6);
				strcpy(s, blkp);
			} else
				if ((ptr = functs(line)) != 0) {
					if (scan_name(s, ptr))
						return (1);
					strcpy(s, x);
				} else {
					get_name(mainp, 4);
					strcpy(s, mainp);
				}
	return (1);
}

int
scan_name(s, ptr)
	char   *s, *ptr;
{
	char   *sptr;

	/* scan off the name */
	trim(ptr);
	sptr = s;
	while (*ptr != '(' && *ptr != '\n') {
		if (*ptr != ' ' && *ptr != '\t')
			*sptr++ = *ptr;
		ptr++;
	}

	if (sptr == s)
		return (0);

	*sptr++ = '.';
	*sptr++ = 'f';
	*sptr++ = 0;
	return (1);
}

char   *
functs(p)
	char   *p;
{
	char *ptr;

/*      look for typed functions such as: real*8 function,
                character*16 function, character*(*) function  */

	if ((ptr = look(p, "character")) != 0 ||
	    (ptr = look(p, "logical")) != 0 ||
	    (ptr = look(p, "real")) != 0 ||
	    (ptr = look(p, "integer")) != 0 ||
	    (ptr = look(p, "doubleprecision")) != 0 ||
	    (ptr = look(p, "complex")) != 0 ||
	    (ptr = look(p, "doublecomplex")) != 0) {
		while (*ptr == ' ' || *ptr == '\t' || *ptr == '*'
		    || (*ptr >= '0' && *ptr <= '9')
		    || *ptr == '(' || *ptr == ')')
			ptr++;
		ptr = look(ptr, "function");
		return (ptr);
	} else
		return (0);
}
/* 	if first 6 col. blank, return ptr to col. 7,
	if blanks and then tab, return ptr after tab,
	else return 0 (labelled statement, comment or continuation */
char   *
skiplab(p)
	char   *p;
{
	char *ptr;

	for (ptr = p; ptr < &p[6]; ptr++) {
		if (*ptr == ' ')
			continue;
		if (*ptr == '\t') {
			ptr++;
			break;
		}
		return (0);
	}
	return (ptr);
}
/* 	return 0 if m doesn't match initial part of s;
	otherwise return ptr to next char after m in s */
char   *
look(s, m)
	char   *s, *m;
{
	char *sp, *mp;

	sp = s;
	mp = m;
	while (*mp) {
		trim(sp);
		if (*sp++ != *mp++)
			return (0);
	}
	return (sp);
}