--- /dev/null
+.\" $NetBSD: fsplit.1,v 1.9 2003/08/07 11:13:50 agc Exp $
+.\"
+.\" Copyright (c) 1983, 1990, 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. 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.
+.\"
+.\" from: @(#)fsplit.1 8.1 (Berkeley) 6/6/93
+.\"
+.Dd June 6, 1993
+.Dt FSPLIT 1
+.Os
+.Sh NAME
+.Nm fsplit
+.Nd split a multi-routine Fortran file into individual files
+.Sh SYNOPSIS
+.Nm
+.Op Fl e Ar efile
+\&...
+.Op Ar file
+.Sh DESCRIPTION
+.Nm
+takes as input either a file or standard input containing Fortran source code.
+It attempts to split the input into separate routine files of the
+form
+.Ar name.f ,
+where
+.Ar name
+is the name of the program unit (e.g. function, subroutine, block data or
+program).
+The name for unnamed block data subprograms has the form
+.Ar blkdtaNNN.f
+where NNN is three digits and a file of this name does not already exist.
+For unnamed main programs the name has the form
+.Ar mainNNN.f .
+If there is an error in classifying a program unit, or if
+.Ar name.f
+already exists,
+the program unit will be put in a file of the form
+.Ar zzzNNN.f
+where
+.Ar zzzNNN.f
+does not already exist.
+.Pp
+.Bl -tag -width Fl
+.It Fl e Ar efile
+Normally each subprogram unit is split into a separate file.
+When the
+.Fl e
+option is used, only the specified subprogram units are split into separate
+files.
+E.g.:
+.Pp
+.Dl fsplit -e readit -e doit prog.f
+.Pp
+will split readit and doit into separate files.
+.El
+.Sh DIAGNOSTICS
+If names specified via the
+.Fl e
+option are not found, a diagnostic is written to
+standard error.
+.Sh HISTORY
+The
+.Nm
+command
+appeared in
+.Bx 4.2 .
+.Sh AUTHORS
+Asa Romberger and Jerry Berkman
+.Sh BUGS
+.Nm
+assumes the subprogram name is on the first noncomment line of the subprogram
+unit.
+Nonstandard source formats may confuse
+.Nm .
+.Pp
+It is hard to use
+.Fl e
+for unnamed main programs and block data subprograms since you must
+predict the created file name.
--- /dev/null
+/*
+ * 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. 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.
+ */
+
+#include <sys/cdefs.h>
+#ifndef lint
+__COPYRIGHT("@(#) Copyright (c) 1983, 1993\
+ The Regents of the University of California. All rights reserved.");
+#endif /* not lint */
+
+#ifndef lint
+#if 0
+static char sccsid[] = "from: @(#)fsplit.c 8.1 (Berkeley) 6/6/93";
+#else
+__RCSID("$NetBSD: fsplit.c,v 1.28 2011/09/16 15:39:26 joerg Exp $");
+#endif
+#endif /* not lint */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#include <assert.h>
+#include <ctype.h>
+#include <err.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <unistd.h>
+
+/*
+ * 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
+static char buf[BSZ];
+static FILE *ifp;
+
+static char x[] = "zzz000.f";
+static char mainp[] = "main000.f";
+static char blkp[] = "blkdta000.f";
+
+__dead static void badparms(void);
+static const char *functs(const char *);
+static int get_line(void);
+static void get_name(char *, int);
+static int lend(void);
+static int lname(char *, size_t);
+static const char *look(const char *, const char *);
+static int saveit(const char *);
+static int scan_name(char *, size_t, const char *);
+static const char *skiplab(const char *);
+static const char *skipws(const char *);
+
+struct extract {
+ bool found;
+ char *name;
+};
+
+#define MAXEXTONLY 100
+static struct extract extonly[MAXEXTONLY];
+static int numextonly = 0;
+
+int
+main(int argc, char **argv)
+{
+ FILE *ofp; /* output file */
+ int rv; /* 1 if got card in output file, 0 otherwise */
+ int nflag; /* 1 if got name of subprog., 0 otherwise */
+ int retval, i, ch;
+ char name[80];
+
+ while ((ch = getopt(argc, argv, "e:")) != -1) {
+ switch (ch) {
+ case 'e':
+ if (numextonly >= MAXEXTONLY) {
+ errx(1, "Too many -e options");
+ }
+ extonly[numextonly].name = optarg;
+ extonly[numextonly].found = false;
+ numextonly++;
+ break;
+ default:
+ badparms();
+ break;
+ }
+ }
+
+ if (argc > 2) {
+ badparms();
+ } else if (argc == 2) {
+ if ((ifp = fopen(argv[1], "r")) == NULL) {
+ err(1, "%s", argv[1]);
+ }
+ } else {
+ ifp = stdin;
+ }
+
+ for (;;) {
+ /*
+ * Look for a temp file that doesn't correspond to an
+ * existing file.
+ */
+
+ get_name(x, 3);
+ ofp = fopen(x, "w");
+ if (ofp == NULL) {
+ err(1, "%s", x);
+ }
+ nflag = 0;
+ rv = 0;
+ while (get_line() > 0) {
+ rv = 1;
+ fprintf(ofp, "%s", buf);
+ /* look for an 'end' statement */
+ if (lend()) {
+ break;
+ }
+ /* if no name yet, try and find one */
+ if (nflag == 0) {
+ nflag = lname(name, sizeof(name));
+ }
+ }
+ fclose(ofp);
+ if (rv == 0) {
+ /* no lines in file, forget the file */
+ unlink(x);
+ retval = 0;
+ for (i = 0; i < numextonly; i++) {
+ if (!extonly[i].found) {
+ retval = 1;
+ warnx("%s not found", extonly[i].name);
+ }
+ }
+ exit(retval);
+ }
+ if (nflag) {
+ /* rename the file */
+ if (saveit(name)) {
+ struct stat sbuf;
+
+ if (stat(name, &sbuf) < 0) {
+ if (rename(x, name) < 0) {
+ warn("%s: rename", x);
+ printf("%s left in %s\n",
+ name, x);
+ } else {
+ 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 (numextonly == 0) {
+ printf("%s\n", x);
+ } else {
+ unlink(x);
+ }
+ }
+}
+
+static void
+badparms(void)
+{
+ err(1, "Usage: fsplit [-e efile] ... [file]");
+}
+
+static int
+saveit(const char *name)
+{
+ int i;
+ char fname[50];
+ size_t fnamelen;
+
+ if (numextonly == 0) {
+ return 1;
+ }
+ strlcpy(fname, name, sizeof(fname));
+ fnamelen = strlen(fname);
+ assert(fnamelen > 2);
+ assert(fname[fnamelen-2] = '.');
+ assert(fname[fnamelen-1] = 'f');
+ fname[fnamelen-2] = '\0';
+
+ for (i = 0; i < numextonly; i++) {
+ if (strcmp(fname, extonly[i].name) == 0) {
+ extonly[i].found = true;
+ return 1;
+ }
+ }
+ return 0;
+}
+
+static void
+get_name(char *name, int letters)
+{
+ struct stat sbuf;
+ 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.\n");
+ }
+ }
+}
+
+static int
+get_line(void)
+{
+ 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) {
+ /* nothing */
+ }
+ warnx("Line truncated to %d characters.", BSZ);
+ return 1;
+}
+
+/*
+ * Return 1 for 'end' alone on card (up to col. 72), 0 otherwise.
+ */
+static int
+lend(void)
+{
+ const char *p;
+
+ if ((p = skiplab(buf)) == 0) {
+ return 0;
+ }
+ p = skipws(p);
+ if (*p != 'e' && *p != 'E') {
+ return 0;
+ }
+ p++;
+ p = skipws(p);
+ if (*p != 'n' && *p != 'N') {
+ return 0;
+ }
+ p++;
+ p = skipws(p);
+ if (*p != 'd' && *p != 'D') {
+ return 0;
+ }
+ p++;
+ p = skipws(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.
+ */
+static int
+lname(char *s, size_t l)
+{
+#define LINESIZE 80
+ const 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 = skipws(buf);
+ if (*ptr == '\n') {
+ return 0;
+ }
+
+ ptr = skiplab(buf);
+ if (ptr == NULL) {
+ return 0;
+ }
+
+ /* copy to buffer and converting to lower case */
+ p = ptr;
+ while (*p && p <= &buf[71] ) {
+ *iptr = tolower((unsigned char)*p);
+ iptr++;
+ p++;
+ }
+ *iptr = '\n';
+
+ if ((ptr = look(line, "subroutine")) != NULL ||
+ (ptr = look(line, "function")) != NULL ||
+ (ptr = functs(line)) != NULL) {
+ if (scan_name(s, l, ptr)) {
+ return 1;
+ }
+ strlcpy(s, x, l);
+ } else if ((ptr = look(line, "program")) != NULL) {
+ if (scan_name(s, l, ptr)) {
+ return 1;
+ }
+ get_name(mainp, 4);
+ strlcpy(s, mainp, l);
+ } else if ((ptr = look(line, "blockdata")) != NULL) {
+ if (scan_name(s, l, ptr)) {
+ return 1;
+ }
+ get_name(blkp, 6);
+ strlcpy(s, blkp, l);
+ } else if ((ptr = functs(line)) != NULL) {
+ if (scan_name(s, l, ptr)) {
+ return 1;
+ }
+ strlcpy(s, x, l);
+ } else {
+ get_name(mainp, 4);
+ strlcpy(s, mainp, l);
+ }
+ return 1;
+}
+
+static int
+scan_name(char *s, size_t smax, const char *ptr)
+{
+ char *sptr;
+ size_t sptrmax;
+
+ /* scan off the name */
+ ptr = skipws(ptr);
+ sptr = s;
+ sptrmax = smax - 3;
+ while (*ptr != '(' && *ptr != '\n') {
+ if (*ptr != ' ' && *ptr != '\t' && *ptr != '/') {
+ if (sptrmax == 0) {
+ /* Not sure this is the right thing, so warn */
+ warnx("Output name too long; truncated");
+ break;
+ }
+ *sptr++ = *ptr;
+ sptrmax--;
+ }
+ ptr++;
+ }
+
+ if (sptr == s) {
+ return 0;
+ }
+
+ *sptr++ = '.';
+ *sptr++ = 'f';
+ *sptr++ = '\0';
+ return 1;
+}
+
+/*
+ * look for typed functions such as: real*8 function,
+ * character*16 function, character*(*) function
+ */
+static const char *
+functs(const char *p)
+{
+ const char *ptr;
+
+ if ((ptr = look(p, "character")) != NULL ||
+ (ptr = look(p, "logical")) != NULL ||
+ (ptr = look(p, "real")) != NULL ||
+ (ptr = look(p, "integer")) != NULL ||
+ (ptr = look(p, "doubleprecision")) != NULL ||
+ (ptr = look(p, "complex")) != NULL ||
+ (ptr = look(p, "doublecomplex")) != NULL) {
+ while (*ptr == ' ' || *ptr == '\t' || *ptr == '*'
+ || (*ptr >= '0' && *ptr <= '9')
+ || *ptr == '(' || *ptr == ')') {
+ ptr++;
+ }
+ ptr = look(ptr, "function");
+ return ptr;
+ }
+ else {
+ return NULL;
+ }
+}
+
+/*
+ * if first 6 col. blank, return ptr to col. 7,
+ * if blanks and then tab, return ptr after tab,
+ * else return NULL (labelled statement, comment or continuation)
+ */
+static const char *
+skiplab(const char *p)
+{
+ const char *ptr;
+
+ for (ptr = p; ptr < &p[6]; ptr++) {
+ if (*ptr == ' ')
+ continue;
+ if (*ptr == '\t') {
+ ptr++;
+ break;
+ }
+ return NULL;
+ }
+ return ptr;
+}
+
+/*
+ * return NULL if m doesn't match initial part of s;
+ * otherwise return ptr to next char after m in s
+ */
+static const char *
+look(const char *s, const char *m)
+{
+ const char *sp, *mp;
+
+ sp = s; mp = m;
+ while (*mp) {
+ sp = skipws(sp);
+ if (*sp++ != *mp++)
+ return NULL;
+ }
+ return sp;
+}
+
+static const char *
+skipws(const char *p)
+{
+ while (*p == ' ' || *p == '\t') {
+ p++;
+ }
+ return p;
+}