Importing usr.bin/fsplit
No Minix-specific changes needed. Change-Id: I78021e6485b40a5b9f98b5d0e5ce0dc82b1ae46a
This commit is contained in:
Thomas Cort
parent
a15f368b9d
commit
97b7aef1ba
6 changed files with 616 additions and 1 deletions
|
|
@ -320,6 +320,7 @@
|
||||||
./usr/bin/format minix-sys
|
./usr/bin/format minix-sys
|
||||||
./usr/bin/fortune minix-sys
|
./usr/bin/fortune minix-sys
|
||||||
./usr/bin/from minix-sys
|
./usr/bin/from minix-sys
|
||||||
|
./usr/bin/fsplit minix-sys
|
||||||
./usr/bin/fstat minix-sys
|
./usr/bin/fstat minix-sys
|
||||||
./usr/bin/ftp minix-sys
|
./usr/bin/ftp minix-sys
|
||||||
./usr/bin/g++ minix-sys gcccmds
|
./usr/bin/g++ minix-sys gcccmds
|
||||||
|
|
@ -1889,6 +1890,7 @@
|
||||||
./usr/man/man1/fortune.1 minix-sys
|
./usr/man/man1/fortune.1 minix-sys
|
||||||
./usr/man/man1/from.1 minix-sys
|
./usr/man/man1/from.1 minix-sys
|
||||||
./usr/man/man1/fsck.mfs.1 minix-sys
|
./usr/man/man1/fsck.mfs.1 minix-sys
|
||||||
|
./usr/man/man1/fsplit.1 minix-sys
|
||||||
./usr/man/man1/ftp.1 minix-sys
|
./usr/man/man1/ftp.1 minix-sys
|
||||||
./usr/man/man1/g++.1 minix-sys gcccmds
|
./usr/man/man1/g++.1 minix-sys gcccmds
|
||||||
./usr/man/man1/gcc.1 minix-sys gcccmds
|
./usr/man/man1/gcc.1 minix-sys gcccmds
|
||||||
|
|
|
||||||
|
|
@ -164,6 +164,7 @@
|
||||||
2013/10/17 12:00:00,usr.bin/env
|
2013/10/17 12:00:00,usr.bin/env
|
||||||
2013/05/31 12:00:00,usr.bin/finger
|
2013/05/31 12:00:00,usr.bin/finger
|
||||||
2013/03/22 12:00:00,usr.bin/from
|
2013/03/22 12:00:00,usr.bin/from
|
||||||
|
2012/10/17 12:00:00,usr.bin/fsplit
|
||||||
2013/04/05 12:00:00,usr.bin/ftp
|
2013/04/05 12:00:00,usr.bin/ftp
|
||||||
2013/03/18 12:00:00,usr.bin/head
|
2013/03/18 12:00:00,usr.bin/head
|
||||||
2012/10/17 12:00:00,usr.bin/genassym
|
2012/10/17 12:00:00,usr.bin/genassym
|
||||||
|
|
|
||||||
|
|
@ -11,7 +11,7 @@ SUBDIR= asa \
|
||||||
dirname du \
|
dirname du \
|
||||||
env expand \
|
env expand \
|
||||||
finger from \
|
finger from \
|
||||||
ftp genassym getopt \
|
fsplit ftp genassym getopt \
|
||||||
head indent infocmp join \
|
head indent infocmp join \
|
||||||
ldd leave \
|
ldd leave \
|
||||||
login logname lorder m4 \
|
login logname lorder m4 \
|
||||||
|
|
|
||||||
6
usr.bin/fsplit/Makefile
Normal file
6
usr.bin/fsplit/Makefile
Normal file
|
|
@ -0,0 +1,6 @@
|
||||||
|
# $NetBSD: Makefile,v 1.6 2009/04/14 22:15:20 lukem Exp $
|
||||||
|
# from: @(#)Makefile 8.1 (Berkeley) 6/6/93
|
||||||
|
|
||||||
|
PROG= fsplit
|
||||||
|
|
||||||
|
.include <bsd.prog.mk>
|
||||||
105
usr.bin/fsplit/fsplit.1
Normal file
105
usr.bin/fsplit/fsplit.1
Normal file
|
|
@ -0,0 +1,105 @@
|
||||||
|
.\" $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.
|
||||||
501
usr.bin/fsplit/fsplit.c
Normal file
501
usr.bin/fsplit/fsplit.c
Normal file
|
|
@ -0,0 +1,501 @@
|
||||||
|
/*
|
||||||
|
* 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;
|
||||||
|
}
|
||||||
Loading…
Reference in a new issue