1 /* 2 * Copyright (c) 1983, 1993 3 * The Regents of the University of California. All rights reserved. 4 * 5 * This code is derived from software contributed to Berkeley by 6 * Asa Romberger and Jerry Berkman. 7 * 8 * Redistribution and use in source and binary forms, with or without 9 * modification, are permitted provided that the following conditions 10 * are met: 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. 19 * 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 30 * SUCH DAMAGE. 31 */ 32 33 #include <sys/cdefs.h> 34 #ifndef lint 35 __COPYRIGHT("@(#) Copyright (c) 1983, 1993\ 36 The Regents of the University of California. All rights reserved."); 37 #endif /* not lint */ 38 39 #ifndef lint 40 #if 0 41 static char sccsid[] = "from: @(#)fsplit.c 8.1 (Berkeley) 6/6/93"; 42 #else 43 __RCSID("$NetBSD: fsplit.c,v 1.30 2015/06/16 22:54:10 christos Exp $"); 44 #endif 45 #endif /* not lint */ 46 47 #include <sys/types.h> 48 #include <sys/stat.h> 49 50 #include <assert.h> 51 #include <ctype.h> 52 #include <err.h> 53 #include <stdbool.h> 54 #include <stdio.h> 55 #include <stdlib.h> 56 #include <string.h> 57 #include <unistd.h> 58 59 /* 60 * usage: fsplit [-e efile] ... [file] 61 * 62 * split single file containing source for several fortran programs 63 * and/or subprograms into files each containing one 64 * subprogram unit. 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 69 * form zzz000.f . 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. 75 * 76 * Modified Feb., 1983 by Jerry Berkman, Computing Services, U.C. Berkeley. 77 * - added comments 78 * - more function types: double complex, character*(*), etc. 79 * - fixed minor bugs 80 * - instead of all unnamed going into zNNN.f, put mains in 81 * mainNNN.f, block datas in blkdtaNNN.f, dups in zzzNNN.f . 82 */ 83 84 #define BSZ 512 85 static char buf[BSZ]; 86 static FILE *ifp; 87 88 static char x[] = "zzz000.f"; 89 static char mainp[] = "main000.f"; 90 static char blkp[] = "blkdta000.f"; 91 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 *); 103 104 struct extract { 105 bool found; 106 char *name; 107 }; 108 109 #define MAXEXTONLY 100 110 static struct extract extonly[MAXEXTONLY]; 111 static int numextonly = 0; 112 113 int 114 main(int argc, char **argv) 115 { 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 */ 119 int retval, i, ch; 120 char name[80]; 121 122 while ((ch = getopt(argc, argv, "e:")) != -1) { 123 switch (ch) { 124 case 'e': 125 if (numextonly >= MAXEXTONLY) { 126 errx(1, "Too many -e options"); 127 } 128 extonly[numextonly].name = optarg; 129 extonly[numextonly].found = false; 130 numextonly++; 131 break; 132 default: 133 badparms(); 134 break; 135 } 136 } 137 138 if (argc > 2) { 139 badparms(); 140 } else if (argc == 2) { 141 if ((ifp = fopen(argv[1], "r")) == NULL) { 142 err(1, "%s", argv[1]); 143 } 144 } else { 145 ifp = stdin; 146 } 147 148 for (;;) { 149 /* 150 * Look for a temp file that doesn't correspond to an 151 * existing file. 152 */ 153 154 get_name(x, 3); 155 ofp = fopen(x, "w"); 156 if (ofp == NULL) { 157 err(1, "%s", x); 158 } 159 nflag = 0; 160 rv = 0; 161 while (get_line() > 0) { 162 rv = 1; 163 fprintf(ofp, "%s", buf); 164 /* look for an 'end' statement */ 165 if (lend()) { 166 break; 167 } 168 /* if no name yet, try and find one */ 169 if (nflag == 0) { 170 nflag = lname(name, sizeof(name)); 171 } 172 } 173 fclose(ofp); 174 if (rv == 0) { 175 /* no lines in file, forget the file */ 176 unlink(x); 177 retval = 0; 178 for (i = 0; i < numextonly; i++) { 179 if (!extonly[i].found) { 180 retval = 1; 181 warnx("%s not found", extonly[i].name); 182 } 183 } 184 exit(retval); 185 } 186 if (nflag) { 187 /* rename the file */ 188 if (saveit(name)) { 189 struct stat sbuf; 190 191 if (stat(name, &sbuf) < 0) { 192 if (rename(x, name) < 0) { 193 warn("%s: rename", x); 194 printf("%s left in %s\n", 195 name, x); 196 } else { 197 printf("%s\n", name); 198 } 199 continue; 200 } else if (strcmp(name, x) == 0) { 201 printf("%s\n", x); 202 continue; 203 } 204 printf("%s already exists, put in %s\n", 205 name, x); 206 continue; 207 } else { 208 unlink(x); 209 continue; 210 } 211 } 212 if (numextonly == 0) { 213 printf("%s\n", x); 214 } else { 215 unlink(x); 216 } 217 } 218 } 219 220 static void 221 badparms(void) 222 { 223 err(1, "Usage: fsplit [-e efile] ... [file]"); 224 } 225 226 static int 227 saveit(const char *name) 228 { 229 int i; 230 char fname[50]; 231 size_t fnamelen; 232 233 if (numextonly == 0) { 234 return 1; 235 } 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'; 243 244 for (i = 0; i < numextonly; i++) { 245 if (strcmp(fname, extonly[i].name) == 0) { 246 extonly[i].found = true; 247 return 1; 248 } 249 } 250 return 0; 251 } 252 253 static void 254 get_name(char *name, int letters) 255 { 256 struct stat sbuf; 257 char *ptr; 258 259 while (stat(name, &sbuf) >= 0) { 260 for (ptr = name + letters + 2; ptr >= name + letters; ptr--) { 261 (*ptr)++; 262 if (*ptr <= '9') 263 break; 264 *ptr = '0'; 265 } 266 if (ptr < name + letters) { 267 errx(1, "Ran out of file names."); 268 } 269 } 270 } 271 272 static int 273 get_line(void) 274 { 275 char *ptr; 276 277 for (ptr = buf; ptr < &buf[BSZ]; ) { 278 *ptr = getc(ifp); 279 if (feof(ifp)) 280 return -1; 281 if (*ptr++ == '\n') { 282 *ptr = '\0'; 283 return 1; 284 } 285 } 286 while (getc(ifp) != '\n' && feof(ifp) == 0) { 287 /* nothing */ 288 } 289 warnx("Line truncated to %d characters.", BSZ); 290 return 1; 291 } 292 293 /* 294 * Return 1 for 'end' alone on card (up to col. 72), 0 otherwise. 295 */ 296 static int 297 lend(void) 298 { 299 const char *p; 300 301 if ((p = skiplab(buf)) == 0) { 302 return 0; 303 } 304 p = skipws(p); 305 if (*p != 'e' && *p != 'E') { 306 return 0; 307 } 308 p++; 309 p = skipws(p); 310 if (*p != 'n' && *p != 'N') { 311 return 0; 312 } 313 p++; 314 p = skipws(p); 315 if (*p != 'd' && *p != 'D') { 316 return 0; 317 } 318 p++; 319 p = skipws(p); 320 if (p - buf >= 72 || *p == '\n') { 321 return 1; 322 } 323 return 0; 324 } 325 326 /* 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. 331 */ 332 static int 333 lname(char *s, size_t l) 334 { 335 #define LINESIZE 80 336 const char *ptr, *p; 337 char line[LINESIZE], *iptr = line; 338 339 /* first check for comment cards */ 340 if (buf[0] == 'c' || buf[0] == 'C' || buf[0] == '*') { 341 return 0; 342 } 343 ptr = skipws(buf); 344 if (*ptr == '\n') { 345 return 0; 346 } 347 348 ptr = skiplab(buf); 349 if (ptr == NULL) { 350 return 0; 351 } 352 353 /* copy to buffer and converting to lower case */ 354 p = ptr; 355 while (*p && p <= &buf[71] ) { 356 *iptr = tolower((unsigned char)*p); 357 iptr++; 358 p++; 359 } 360 *iptr = '\n'; 361 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)) { 366 return 1; 367 } 368 strlcpy(s, x, l); 369 } else if ((ptr = look(line, "program")) != NULL) { 370 if (scan_name(s, l, ptr)) { 371 return 1; 372 } 373 get_name(mainp, 4); 374 strlcpy(s, mainp, l); 375 } else if ((ptr = look(line, "blockdata")) != NULL) { 376 if (scan_name(s, l, ptr)) { 377 return 1; 378 } 379 get_name(blkp, 6); 380 strlcpy(s, blkp, l); 381 } else if ((ptr = functs(line)) != NULL) { 382 if (scan_name(s, l, ptr)) { 383 return 1; 384 } 385 strlcpy(s, x, l); 386 } else { 387 get_name(mainp, 4); 388 strlcpy(s, mainp, l); 389 } 390 return 1; 391 } 392 393 static int 394 scan_name(char *s, size_t smax, const char *ptr) 395 { 396 char *sptr; 397 size_t sptrmax; 398 399 /* scan off the name */ 400 ptr = skipws(ptr); 401 sptr = s; 402 sptrmax = smax - 3; 403 while (*ptr != '(' && *ptr != '\n') { 404 if (*ptr != ' ' && *ptr != '\t' && *ptr != '/') { 405 if (sptrmax == 0) { 406 /* Not sure this is the right thing, so warn */ 407 warnx("Output name too long; truncated"); 408 break; 409 } 410 *sptr++ = *ptr; 411 sptrmax--; 412 } 413 ptr++; 414 } 415 416 if (sptr == s) { 417 return 0; 418 } 419 420 *sptr++ = '.'; 421 *sptr++ = 'f'; 422 *sptr++ = '\0'; 423 return 1; 424 } 425 426 /* 427 * look for typed functions such as: real*8 function, 428 * character*16 function, character*(*) function 429 */ 430 static const char * 431 functs(const char *p) 432 { 433 const char *ptr; 434 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 == ')') { 445 ptr++; 446 } 447 ptr = look(ptr, "function"); 448 return ptr; 449 } 450 else { 451 return NULL; 452 } 453 } 454 455 /* 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) 459 */ 460 static const char * 461 skiplab(const char *p) 462 { 463 const char *ptr; 464 465 for (ptr = p; ptr < &p[6]; ptr++) { 466 if (*ptr == ' ') 467 continue; 468 if (*ptr == '\t') { 469 ptr++; 470 break; 471 } 472 return NULL; 473 } 474 return ptr; 475 } 476 477 /* 478 * return NULL if m doesn't match initial part of s; 479 * otherwise return ptr to next char after m in s 480 */ 481 static const char * 482 look(const char *s, const char *m) 483 { 484 const char *sp, *mp; 485 486 sp = s; mp = m; 487 while (*mp) { 488 sp = skipws(sp); 489 if (*sp++ != *mp++) 490 return NULL; 491 } 492 return sp; 493 } 494 495 static const char * 496 skipws(const char *p) 497 { 498 while (*p == ' ' || *p == '\t') { 499 p++; 500 } 501 return p; 502 } 503
Indexes created Wed Sep 24 05:09:52 GMT 2025