503 lines
11 KiB
C
503 lines
11 KiB
C
/*
|
|
* 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.29 2013/01/23 20:39:46 riastradh 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);
|
|
/* Guaranteed by scan_name. */
|
|
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;
|
|
}
|