d/freebsd-dev
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Say goodbye to some crufty old fortran code.

Browse Source 
Reviewed by:	current
This commit is contained in:
Kris Kennaway 1999-12-22 14:30:42 +00:00
parent 8f4620bc42
commit f972508889
Notes: svn2git 2020-12-20 02:59:44 +00:00 
svn path=/head/; revision=55000
7 changed files with 0 additions and 1041 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
usr.bin/Makefile
View File

@ -47,9 +47,7 @@ SUBDIR= apply \
finger \
fmt \
fold \
fpr \
from \
fsplit \
fstat \
ftp \
gencat \

5
usr.bin/fpr/Makefile
View File

@ -1,5 +0,0 @@
# @(#)Makefile 8.1 (Berkeley) 6/6/93
PROG= fpr
.include <bsd.prog.mk>

84
usr.bin/fpr/fpr.1
View File

@ -1,84 +0,0 @@
.\" Copyright (c) 1989, 1990, 1993
.\" The Regents of the University of California. All rights reserved.
.\"
.\" This code is derived from software contributed to Berkeley by
.\" Robert Corbett.
.\" 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.
.\"
.\" @(#)fpr.1 8.1 (Berkeley) 6/6/93
.\" $FreeBSD$
.\"
.Dd June 6, 1993
.Dt FPR 1
.Os BSD 4.2
.Sh NAME
.Nm fpr
.Nd print Fortran file
.Sh SYNOPSIS
.Nm fpr
.Sh DESCRIPTION
.Nm Fpr
is a filter that transforms files formatted according to
Fortran's carriage control conventions into files formatted
according to
.Ux
line printer conventions.
.Pp
.Nm Fpr
copies its input onto its output, replacing the carriage
control characters with characters that will produce the intended
effects when printed using
.Xr lpr 1 .
The first character of each line determines the vertical spacing as follows:
.Bd -ragged -offset indent -compact
.Bl -column Character
.It Blank One line
.It 0 Two lines
.It 1 To first line of next page
.It + No advance
.El
.Ed
.Pp
A blank line is treated as if its first
character is a blank. A blank that appears as a carriage control
character is deleted. A zero is changed to a newline. A one is
changed to a form feed. The effects of a "+" are simulated using
backspaces.
.Sh EXAMPLES
.Dl a.out \&| fpr \&| lpr
.Pp
.Dl fpr \&< f77.output \&| lpr
.Sh HISTORY
The
.Nm fpr
command
appeared in
.Bx 4.2 .
.Sh BUGS
Results are undefined for input lines longer than 170 characters.

410
usr.bin/fpr/fpr.c
View File

@ -1,410 +0,0 @@
/*
* Copyright (c) 1989, 1993
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Robert Corbett.
*
* 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) 1989, 1993\n\
The Regents of the University of California. All rights reserved.\n";
#endif /* not lint */
#ifndef lint
static char sccsid[] = "@(#)fpr.c 8.1 (Berkeley) 6/6/93";
#endif /* not lint */
#include <stdio.h>
#define BLANK ' '
#define TAB '\t'
#define NUL '\000'
#define FF '\f'
#define BS '\b'
#define CR '\r'
#define VTAB '\013'
#define EOL '\n'
#define TRUE 1
#define FALSE 0
#define MAXCOL 170
#define TABSIZE 8
#define INITWIDTH 8
typedef
struct column
{
int count;
int width;
char *str;
}
COLUMN;
char cc;
char saved;
int length;
char *text;
int highcol;
COLUMN *line;
int maxpos;
int maxcol;
extern char *malloc();
extern char *calloc();
extern char *realloc();
main()
{
register int ch;
register char ateof;
register int i;
register int errorcount;
init();
errorcount = 0;
ateof = FALSE;
ch = getchar();
if (ch == EOF)
exit(0);
if (ch == EOL)
{
cc = NUL;
ungetc((int) EOL, stdin);
}
else if (ch == BLANK)
cc = NUL;
else if (ch == '1')
cc = FF;
else if (ch == '0')
cc = EOL;
else if (ch == '+')
cc = CR;
else
{
errorcount = 1;
cc = NUL;
ungetc(ch, stdin);
}
while ( ! ateof)
{
gettext();
ch = getchar();
if (ch == EOF)
{
flush();
ateof = TRUE;
}
else if (ch == EOL)
{
flush();
cc = NUL;
ungetc((int) EOL, stdin);
}
else if (ch == BLANK)
{
flush();
cc = NUL;
}
else if (ch == '1')
{
flush();
cc = FF;
}
else if (ch == '0')
{
flush();
cc = EOL;
}
else if (ch == '+')
{
for (i = 0; i < length; i++)
savech(i);
}
else
{
errorcount++;
flush();
cc = NUL;
ungetc(ch, stdin);
}
}
if (errorcount == 1)
fprintf(stderr, "Illegal carriage control - 1 line.\n");
else if (errorcount > 1)
fprintf(stderr, "Illegal carriage control - %d lines.\n", errorcount);
exit(0);
}
init()
{
register COLUMN *cp;
register COLUMN *cend;
register char *sp;
length = 0;
maxpos = MAXCOL;
sp = malloc((unsigned) maxpos);
if (sp == NULL)
nospace();
text = sp;
highcol = -1;
maxcol = MAXCOL;
line = (COLUMN *) calloc(maxcol, (unsigned) sizeof(COLUMN));
if (line == NULL)
nospace();
cp = line;
cend = line + (maxcol-1);
while (cp <= cend)
{
cp->width = INITWIDTH;
sp = calloc(INITWIDTH, (unsigned) sizeof(char));
if (sp == NULL)
nospace();
cp->str = sp;
cp++;
}
}
gettext()
{
register int i;
register char ateol;
register int ch;
register int pos;
i = 0;
ateol = FALSE;
while ( ! ateol)
{
ch = getchar();
if (ch == EOL || ch == EOF)
ateol = TRUE;
else if (ch == TAB)
{
pos = (1 + i/TABSIZE) * TABSIZE;
if (pos > maxpos)
{
maxpos = pos + 10;
text = realloc(text, (unsigned) maxpos);
if (text == NULL)
nospace();
}
while (i < pos)
{
text[i] = BLANK;
i++;
}
}
else if (ch == BS)
{
if (i > 0)
{
i--;
savech(i);
}
}
else if (ch == CR)
{
while (i > 0)
{
i--;
savech(i);
}
}
else if (ch == FF || ch == VTAB)
{
flush();
cc = ch;
i = 0;
}
else
{
if (i >= maxpos)
{
maxpos = i + 10;
text = realloc(text, (unsigned) maxpos);
if (text == NULL)
nospace();
}
text[i] = ch;
i++;
}
}
length = i;
}
savech(col)
int col;
{
register char ch;
register int oldmax;
register COLUMN *cp;
register COLUMN *cend;
register char *sp;
register int newcount;
ch = text[col];
if (ch == BLANK)
return;
saved = TRUE;
if (col >= highcol)
highcol = col;
if (col >= maxcol)
{
oldmax = maxcol;
maxcol = col + 10;
line = (COLUMN *) realloc(line, (unsigned) maxcol*sizeof(COLUMN));
if (line == NULL)
nospace();
cp = line + oldmax;
cend = line + (maxcol - 1);
while (cp <= cend)
{
cp->width = INITWIDTH;
cp->count = 0;
sp = calloc(INITWIDTH, (unsigned) sizeof(char));
if (sp == NULL)
nospace();
cp->str = sp;
cp++;
}
}
cp = line + col;
newcount = cp->count + 1;
if (newcount > cp->width)
{
cp->width = newcount;
sp = realloc(cp->str, (unsigned) newcount*sizeof(char));
if (sp == NULL)
nospace();
cp->str = sp;
}
cp->count = newcount;
cp->str[newcount-1] = ch;
}
flush()
{
register int i;
register int anchor;
register int height;
register int j;
if (cc != NUL)
putchar(cc);
if ( ! saved)
{
i = length;
while (i > 0 && text[i-1] == BLANK)
i--;
length = i;
for (i = 0; i < length; i++)
putchar(text[i]);
putchar(EOL);
return;
}
for (i =0; i < length; i++)
savech(i);
anchor = 0;
while (anchor <= highcol)
{
height = line[anchor].count;
if (height == 0)
{
putchar(BLANK);
anchor++;
}
else if (height == 1)
{
putchar( *(line[anchor].str) );
line[anchor].count = 0;
anchor++;
}
else
{
i = anchor;
while (i < highcol && line[i+1].count > 1)
i++;
for (j = anchor; j <= i; j++)
{
height = line[j].count - 1;
putchar(line[j].str[height]);
line[j].count = height;
}
for (j = anchor; j <= i; j++)
putchar(BS);
}
}
putchar(EOL);
highcol = -1;
}
nospace()
{
fputs("Storage limit exceeded.\n", stderr);
exit(1);
}

5
usr.bin/fsplit/Makefile
View File

@ -1,5 +0,0 @@
# @(#)Makefile 8.1 (Berkeley) 6/6/93
PROG= fsplit
.include <bsd.prog.mk>

106
usr.bin/fsplit/fsplit.1
View File

@ -1,106 +0,0 @@
.\" 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. 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.
.\"
.\" @(#)fsplit.1 8.1 (Berkeley) 6/6/93
.\" $FreeBSD$
.\"
.Dd June 6, 1993
.Dt FSPLIT 1
.Os BSD 4.2
.Sh NAME
.Nm fsplit
.Nd split a multi-routine Fortran file into individual files
.Sh SYNOPSIS
.Nm fsplit
.Op Fl e Ar efile
\&...
.Op Ar file
.Sh DESCRIPTION
.Nm Fsplit
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
.An Asa Romberger
and
.An Jerry Berkman
.Sh BUGS
.Nm Fsplit
assumes the subprogram name is on the first noncomment line of the subprogram
unit. Nonstandard source formats may confuse
.Nm Ns .
.Pp
It is hard to use
.Fl e
for unnamed main programs and block data subprograms since you must
predict the created file name.

429
usr.bin/fsplit/fsplit.c
View File

@ -1,429 +0,0 @@
/*
* 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 const char copyright[] =
"@(#) Copyright (c) 1983, 1993\n\
The Regents of the University of California. All rights reserved.\n";
#endif /* not lint */
#ifndef lint
#if 0
static char sccsid[] = "@(#)fsplit.c 8.1 (Berkeley) 6/6/93";
#endif
static const char rcsid[] =
"$FreeBSD$";
#endif /* not lint */
#include <ctype.h>
#include <err.h>
#include <stdio.h>
#include <string.h>
#include <sys/types.h>
#include <sys/stat.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
char buf[BSZ];
FILE *ifp;
char x[]="zzz000.f",
mainp[]="main000.f",
blkp[]="blkdta000.f";
#define TRUE 1
#define FALSE 0
int extr = FALSE,
extrknt = -1,
extrfnd[100];
char extrbuf[1000],
*extrnames[100];
struct stat sbuf;
#define trim(p) while (*p == ' ' || *p == '\t') p++
int getline __P((void));
void get_name __P((char *, int));
char *functs __P((char *));
int lend __P((void));
int lname __P((char *));
char *look __P((char *, char *));
int saveit __P((char *));
int scan_name __P((char *, char *));
char *skiplab __P((char *));
static void usage __P((void));
int
main(argc, argv)
char **argv;
{
register FILE *ofp; /* output file */
register int rv; /* 1 if got card in output file, 0 otherwise */
register char *ptr;
int nflag, /* 1 if got name of subprog., 0 otherwise */
retval,
i;
char name[20],
*extrptr = extrbuf;
/* 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)
usage();
ptr = argv[1];
}
extrknt = extrknt + 1;
extrnames[extrknt] = extrptr;
extrfnd[extrknt] = FALSE;
while(*ptr) *extrptr++ = *ptr++;
*extrptr++ = 0;
argc--;
argv++;
}
if (argc > 2)
usage();
else if (argc == 2) {
if ((ifp = fopen(argv[1], "r")) == NULL)
errx(1, "cannot open %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");
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);
}
}
static void
usage()
{
fprintf(stderr, "usage: fsplit [-e efile] ... [file]\n");
exit(1);
}
int
saveit(name)
char *name;
{
int i;
char fname[50],
*fptr = fname;
if(!extr) return(1);
while(*name) *fptr++ = *name++;
*--fptr = 0;
*--fptr = 0;
for ( i=0 ; i<=extrknt; i++ )
if( strcmp(fname, extrnames[i]) == 0 ) {
extrfnd[i] = TRUE;
return(1);
}
return(0);
}
void
get_name(name, letters)
char *name;
int letters;
{
register 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()
{
register 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()
{
register 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
register 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 = isupper(*p) ? tolower(*p) : *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;
{
register 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;
{
register 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;
{
register char *sp, *mp;
sp = s; mp = m;
while (*mp) {
trim(sp);
if (*sp++ != *mp++)
return (0);
}
return (sp);
}