2 * Copyright (c) 1983, 1993
3 * The Regents of the University of California. All rights reserved.
5 * This code is derived from software contributed to Berkeley by
6 * Asa Romberger and Jerry Berkman.
8 * Redistribution and use in source and binary forms, with or without
9 * modification, are permitted provided that the following conditions
11 * 1. Redistributions of source code must retain the above copyright
12 * notice, this list of conditions and the following disclaimer.
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 * 3. Neither the name of the University nor the names of its contributors
17 * may be used to endorse or promote products derived from this software
18 * without specific prior written permission.
20 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
21 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
24 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
26 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
27 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
28 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
29 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
33 #include <sys/cdefs.h>
35 __COPYRIGHT("@(#) Copyright (c) 1983, 1993\
36 The Regents of the University of California. All rights reserved.");
41 static char sccsid
[] = "from: @(#)fsplit.c 8.1 (Berkeley) 6/6/93";
43 __RCSID("$NetBSD: fsplit.c,v 1.30 2015/06/16 22:54:10 christos Exp $");
47 #include <sys/types.h>
60 * usage: fsplit [-e efile] ... [file]
62 * split single file containing source for several fortran programs
63 * and/or subprograms into files each containing one
65 * each separate file will be named using the corresponding subroutine,
66 * function, block data or program name if one is found; otherwise
67 * the name will be of the form mainNNN.f or blkdtaNNN.f .
68 * If a file of that name exists, it is saved in a name of the
70 * If -e option is used, then only those subprograms named in the -e
71 * option are split off; e.g.:
72 * fsplit -esub1 -e sub2 prog.f
73 * isolates sub1 and sub2 in sub1.f and sub2.f. The space
74 * after -e is optional.
76 * Modified Feb., 1983 by Jerry Berkman, Computing Services, U.C. Berkeley.
78 * - more function types: double complex, character*(*), etc.
80 * - instead of all unnamed going into zNNN.f, put mains in
81 * mainNNN.f, block datas in blkdtaNNN.f, dups in zzzNNN.f .
88 static char x
[] = "zzz000.f";
89 static char mainp
[] = "main000.f";
90 static char blkp
[] = "blkdta000.f";
92 __dead
static void badparms(void);
93 static const char *functs(const char *);
94 static int get_line(void);
95 static void get_name(char *, int);
96 static int lend(void);
97 static int lname(char *, size_t);
98 static const char *look(const char *, const char *);
99 static int saveit(const char *);
100 static int scan_name(char *, size_t, const char *);
101 static const char *skiplab(const char *);
102 static const char *skipws(const char *);
109 #define MAXEXTONLY 100
110 static struct extract extonly
[MAXEXTONLY
];
111 static int numextonly
= 0;
114 main(int argc
, char **argv
)
116 FILE *ofp
; /* output file */
117 int rv
; /* 1 if got card in output file, 0 otherwise */
118 int nflag
; /* 1 if got name of subprog., 0 otherwise */
122 while ((ch
= getopt(argc
, argv
, "e:")) != -1) {
125 if (numextonly
>= MAXEXTONLY
) {
126 errx(1, "Too many -e options");
128 extonly
[numextonly
].name
= optarg
;
129 extonly
[numextonly
].found
= false;
140 } else if (argc
== 2) {
141 if ((ifp
= fopen(argv
[1], "r")) == NULL
) {
142 err(1, "%s", argv
[1]);
150 * Look for a temp file that doesn't correspond to an
161 while (get_line() > 0) {
163 fprintf(ofp
, "%s", buf
);
164 /* look for an 'end' statement */
168 /* if no name yet, try and find one */
170 nflag
= lname(name
, sizeof(name
));
175 /* no lines in file, forget the file */
178 for (i
= 0; i
< numextonly
; i
++) {
179 if (!extonly
[i
].found
) {
181 warnx("%s not found", extonly
[i
].name
);
187 /* rename the file */
191 if (stat(name
, &sbuf
) < 0) {
192 if (rename(x
, name
) < 0) {
193 warn("%s: rename", x
);
194 printf("%s left in %s\n",
197 printf("%s\n", name
);
200 } else if (strcmp(name
, x
) == 0) {
204 printf("%s already exists, put in %s\n",
212 if (numextonly
== 0) {
223 err(1, "Usage: fsplit [-e efile] ... [file]");
227 saveit(const char *name
)
233 if (numextonly
== 0) {
236 strlcpy(fname
, name
, sizeof(fname
));
237 fnamelen
= strlen(fname
);
238 /* Guaranteed by scan_name. */
239 assert(fnamelen
> 2);
240 assert(fname
[fnamelen
-2] == '.');
241 assert(fname
[fnamelen
-1] == 'f');
242 fname
[fnamelen
-2] = '\0';
244 for (i
= 0; i
< numextonly
; i
++) {
245 if (strcmp(fname
, extonly
[i
].name
) == 0) {
246 extonly
[i
].found
= true;
254 get_name(char *name
, int letters
)
259 while (stat(name
, &sbuf
) >= 0) {
260 for (ptr
= name
+ letters
+ 2; ptr
>= name
+ letters
; ptr
--) {
266 if (ptr
< name
+ letters
) {
267 errx(1, "Ran out of file names.");
277 for (ptr
= buf
; ptr
< &buf
[BSZ
]; ) {
281 if (*ptr
++ == '\n') {
286 while (getc(ifp
) != '\n' && feof(ifp
) == 0) {
289 warnx("Line truncated to %d characters.", BSZ
);
294 * Return 1 for 'end' alone on card (up to col. 72), 0 otherwise.
301 if ((p
= skiplab(buf
)) == 0) {
305 if (*p
!= 'e' && *p
!= 'E') {
310 if (*p
!= 'n' && *p
!= 'N') {
315 if (*p
!= 'd' && *p
!= 'D') {
320 if (p
- buf
>= 72 || *p
== '\n') {
327 * check for keywords for subprograms
328 * return 0 if comment card, 1 if found
329 * name and put in arg string. invent name for unnamed
330 * block datas and main programs.
333 lname(char *s
, size_t l
)
337 char line
[LINESIZE
], *iptr
= line
;
339 /* first check for comment cards */
340 if (buf
[0] == 'c' || buf
[0] == 'C' || buf
[0] == '*') {
353 /* copy to buffer and converting to lower case */
355 while (*p
&& p
<= &buf
[71] ) {
356 *iptr
= tolower((unsigned char)*p
);
362 if ((ptr
= look(line
, "subroutine")) != NULL
||
363 (ptr
= look(line
, "function")) != NULL
||
364 (ptr
= functs(line
)) != NULL
) {
365 if (scan_name(s
, l
, ptr
)) {
369 } else if ((ptr
= look(line
, "program")) != NULL
) {
370 if (scan_name(s
, l
, ptr
)) {
374 strlcpy(s
, mainp
, l
);
375 } else if ((ptr
= look(line
, "blockdata")) != NULL
) {
376 if (scan_name(s
, l
, ptr
)) {
381 } else if ((ptr
= functs(line
)) != NULL
) {
382 if (scan_name(s
, l
, ptr
)) {
388 strlcpy(s
, mainp
, l
);
394 scan_name(char *s
, size_t smax
, const char *ptr
)
399 /* scan off the name */
403 while (*ptr
!= '(' && *ptr
!= '\n') {
404 if (*ptr
!= ' ' && *ptr
!= '\t' && *ptr
!= '/') {
406 /* Not sure this is the right thing, so warn */
407 warnx("Output name too long; truncated");
427 * look for typed functions such as: real*8 function,
428 * character*16 function, character*(*) function
431 functs(const char *p
)
435 if ((ptr
= look(p
, "character")) != NULL
||
436 (ptr
= look(p
, "logical")) != NULL
||
437 (ptr
= look(p
, "real")) != NULL
||
438 (ptr
= look(p
, "integer")) != NULL
||
439 (ptr
= look(p
, "doubleprecision")) != NULL
||
440 (ptr
= look(p
, "complex")) != NULL
||
441 (ptr
= look(p
, "doublecomplex")) != NULL
) {
442 while (*ptr
== ' ' || *ptr
== '\t' || *ptr
== '*'
443 || (*ptr
>= '0' && *ptr
<= '9')
444 || *ptr
== '(' || *ptr
== ')') {
447 ptr
= look(ptr
, "function");
456 * if first 6 col. blank, return ptr to col. 7,
457 * if blanks and then tab, return ptr after tab,
458 * else return NULL (labelled statement, comment or continuation)
461 skiplab(const char *p
)
465 for (ptr
= p
; ptr
< &p
[6]; ptr
++) {
478 * return NULL if m doesn't match initial part of s;
479 * otherwise return ptr to next char after m in s
482 look(const char *s
, const char *m
)
496 skipws(const char *p
)
498 while (*p
== ' ' || *p
== '\t') {