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\n\ 36 The Regents of the University of California. All rights reserved.\n"); 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.10 2003/08/07 11:13:50 agc Exp $"); 44 #endif 45 #endif /* not lint */ 46 47 #include <sys/types.h> 48 #include <sys/stat.h> 49 50 #include <ctype.h> 51 #include <stdio.h> 52 #include <stdlib.h> 53 #include <string.h> 54 #include <unistd.h> 55 56 /* 57 * usage: fsplit [-e efile] ... [file] 58 * 59 * split single file containing source for several fortran programs 60 * and/or subprograms into files each containing one 61 * subprogram unit. 62 * each separate file will be named using the corresponding subroutine, 63 * function, block data or program name if one is found; otherwise 64 * the name will be of the form mainNNN.f or blkdtaNNN.f . 65 * If a file of that name exists, it is saved in a name of the 66 * form zzz000.f . 67 * If -e option is used, then only those subprograms named in the -e 68 * option are split off; e.g.: 69 * fsplit -esub1 -e sub2 prog.f 70 * isolates sub1 and sub2 in sub1.f and sub2.f. The space 71 * after -e is optional. 72 * 73 * Modified Feb., 1983 by Jerry Berkman, Computing Services, U.C. Berkeley. 74 * - added comments 75 * - more function types: double complex, character*(*), etc. 76 * - fixed minor bugs 77 * - instead of all unnamed going into zNNN.f, put mains in 78 * mainNNN.f, block datas in blkdtaNNN.f, dups in zzzNNN.f . 79 */ 80 81 #define BSZ 512 82 char buf[BSZ]; 83 FILE *ifp; 84 char x[]="zzz000.f", 85 mainp[]="main000.f", 86 blkp[]="blkdta000.f"; 87 88 void badparms __P((void)); 89 char *functs __P((char *)); 90 int getline __P((void)); 91 void get_name __P((char *, int)); 92 int main __P((int, char **)); 93 int lend __P((void)); 94 int lname __P((char *, size_t)); 95 char *look __P((char *, char *)); 96 int saveit __P((char *)); 97 int scan_name __P((char *, char *)); 98 char *skiplab __P((char *)); 99 100 #define TRUE 1 101 #define FALSE 0 102 int extr = FALSE, 103 extrknt = -1, 104 extrfnd[100]; 105 char extrbuf[1000], 106 *extrnames[100]; 107 struct stat sbuf; 108 109 #define trim(p) while (*p == ' ' || *p == '\t') p++ 110 111 int 112 main(argc, argv) 113 int argc; 114 char **argv; 115 { 116 FILE *ofp; /* output file */ 117 int rv; /* 1 if got card in output file, 0 otherwise */ 118 char *ptr; 119 int nflag; /* 1 if got name of subprog., 0 otherwise */ 120 int retval, i; 121 char name[20], *extrptr = extrbuf; 122 123 /* scan -e options */ 124 while ( argc > 1 && argv[1][0] == '-' && argv[1][1] == 'e') { 125 extr = TRUE; 126 ptr = argv[1] + 2; 127 if(!*ptr) { 128 argc--; 129 argv++; 130 if(argc <= 1) badparms(); 131 ptr = argv[1]; 132 } 133 extrknt = extrknt + 1; 134 extrnames[extrknt] = extrptr; 135 extrfnd[extrknt] = FALSE; 136 while(*ptr) *extrptr++ = *ptr++; 137 *extrptr++ = 0; 138 argc--; 139 argv++; 140 } 141 142 if (argc > 2) 143 badparms(); 144 else if (argc == 2) { 145 if ((ifp = fopen(argv[1], "r")) == NULL) { 146 fprintf(stderr, "fsplit: cannot open %s\n", argv[1]); 147 exit(1); 148 } 149 } 150 else 151 ifp = stdin; 152 for(;;) { 153 /* look for a temp file that doesn't correspond to an existing file */ 154 get_name(x, 3); 155 ofp = fopen(x, "w"); 156 nflag = 0; 157 rv = 0; 158 while (getline() > 0) { 159 rv = 1; 160 fprintf(ofp, "%s", buf); 161 if (lend()) /* look for an 'end' statement */ 162 break; 163 if (nflag == 0) /* if no name yet, try and find one */ 164 nflag = lname(name, sizeof(name)); 165 } 166 fclose(ofp); 167 if (rv == 0) { /* no lines in file, forget the file */ 168 unlink(x); 169 retval = 0; 170 for ( i = 0; i <= extrknt; i++ ) 171 if(!extrfnd[i]) { 172 retval = 1; 173 fprintf( stderr, "fsplit: %s not found\n", 174 extrnames[i]); 175 } 176 exit( retval ); 177 } 178 if (nflag) { /* rename the file */ 179 if(saveit(name)) { 180 if (stat(name, &sbuf) < 0 ) { 181 link(x, name); 182 unlink(x); 183 printf("%s\n", name); 184 continue; 185 } else if (strcmp(name, x) == 0) { 186 printf("%s\n", x); 187 continue; 188 } 189 printf("%s already exists, put in %s\n", name, x); 190 continue; 191 } else 192 unlink(x); 193 continue; 194 } 195 if(!extr) 196 printf("%s\n", x); 197 else 198 unlink(x); 199 } 200 } 201 202 void 203 badparms() 204 { 205 fprintf(stderr, "fsplit: usage: fsplit [-e efile] ... [file] \n"); 206 exit(1); 207 } 208 209 int 210 saveit(name) 211 char *name; 212 { 213 int i; 214 char fname[50], 215 *fptr = fname; 216 217 if(!extr) return(1); 218 while(*name) *fptr++ = *name++; 219 *--fptr = 0; 220 *--fptr = 0; 221 for ( i=0 ; i<=extrknt; i++ ) 222 if( strcmp(fname, extrnames[i]) == 0 ) { 223 extrfnd[i] = TRUE; 224 return(1); 225 } 226 return(0); 227 } 228 229 void 230 get_name(name, letters) 231 char *name; 232 int letters; 233 { 234 char *ptr; 235 236 while (stat(name, &sbuf) >= 0) { 237 for (ptr = name + letters + 2; ptr >= name + letters; ptr--) { 238 (*ptr)++; 239 if (*ptr <= '9') 240 break; 241 *ptr = '0'; 242 } 243 if(ptr < name + letters) { 244 fprintf( stderr, "fsplit: ran out of file names\n"); 245 exit(1); 246 } 247 } 248 } 249 250 int 251 getline() 252 { 253 char *ptr; 254 255 for (ptr = buf; ptr < &buf[BSZ]; ) { 256 *ptr = getc(ifp); 257 if (feof(ifp)) 258 return (-1); 259 if (*ptr++ == '\n') { 260 *ptr = 0; 261 return (1); 262 } 263 } 264 while (getc(ifp) != '\n' && feof(ifp) == 0) ; 265 fprintf(stderr, "line truncated to %d characters\n", BSZ); 266 return (1); 267 } 268 269 /* return 1 for 'end' alone on card (up to col. 72), 0 otherwise */ 270 int 271 lend() 272 { 273 char *p; 274 275 if ((p = skiplab(buf)) == 0) 276 return (0); 277 trim(p); 278 if (*p != 'e' && *p != 'E') return(0); 279 p++; 280 trim(p); 281 if (*p != 'n' && *p != 'N') return(0); 282 p++; 283 trim(p); 284 if (*p != 'd' && *p != 'D') return(0); 285 p++; 286 trim(p); 287 if (p - buf >= 72 || *p == '\n') 288 return (1); 289 return (0); 290 } 291 292 /* check for keywords for subprograms 293 return 0 if comment card, 1 if found 294 name and put in arg string. invent name for unnamed 295 block datas and main programs. */ 296 297 int 298 lname(s, l) 299 char *s; 300 size_t l; 301 { 302 # define LINESIZE 80 303 char *ptr, *p; 304 char line[LINESIZE], *iptr = line; 305 306 /* first check for comment cards */ 307 if(buf[0] == 'c' || buf[0] == 'C' || buf[0] == '*') return(0); 308 ptr = buf; 309 while (*ptr == ' ' || *ptr == '\t') ptr++; 310 if(*ptr == '\n') return(0); 311 312 313 ptr = skiplab(buf); 314 if (ptr == 0) 315 return (0); 316 317 318 /* copy to buffer and converting to lower case */ 319 p = ptr; 320 while (*p && p <= &buf[71] ) { 321 *iptr = isupper((unsigned char)*p) ? tolower(*p) : *p; 322 iptr++; 323 p++; 324 } 325 *iptr = '\n'; 326 327 if ((ptr = look(line, "subroutine")) != 0 || 328 (ptr = look(line, "function")) != 0 || 329 (ptr = functs(line)) != 0) { 330 if(scan_name(s, ptr)) return(1); 331 strlcpy(s, x, l); 332 } else if((ptr = look(line, "program")) != 0) { 333 if(scan_name(s, ptr)) return(1); 334 get_name(mainp, 4); 335 strlcpy(s, mainp, l); 336 } else if((ptr = look(line, "blockdata")) != 0) { 337 if(scan_name(s, ptr)) return(1); 338 get_name( blkp, 6); 339 strlcpy(s, blkp, l); 340 } else if((ptr = functs(line)) != 0) { 341 if(scan_name(s, ptr)) return(1); 342 strlcpy(s, x, l); 343 } else { 344 get_name(mainp, 4); 345 strlcpy(s, mainp, l); 346 } 347 return(1); 348 } 349 350 int 351 scan_name(s, ptr) 352 char *s, *ptr; 353 { 354 char *sptr; 355 356 /* scan off the name */ 357 trim(ptr); 358 sptr = s; 359 while (*ptr != '(' && *ptr != '\n') { 360 if (*ptr != ' ' && *ptr != '\t') 361 *sptr++ = *ptr; 362 ptr++; 363 } 364 365 if (sptr == s) return(0); 366 367 *sptr++ = '.'; 368 *sptr++ = 'f'; 369 *sptr++ = 0; 370 return(1); 371 } 372 373 char * 374 functs(p) 375 char *p; 376 { 377 char *ptr; 378 379 /* look for typed functions such as: real*8 function, 380 character*16 function, character*(*) function */ 381 382 if((ptr = look(p,"character")) != 0 || 383 (ptr = look(p,"logical")) != 0 || 384 (ptr = look(p,"real")) != 0 || 385 (ptr = look(p,"integer")) != 0 || 386 (ptr = look(p,"doubleprecision")) != 0 || 387 (ptr = look(p,"complex")) != 0 || 388 (ptr = look(p,"doublecomplex")) != 0 ) { 389 while ( *ptr == ' ' || *ptr == '\t' || *ptr == '*' 390 || (*ptr >= '0' && *ptr <= '9') 391 || *ptr == '(' || *ptr == ')') ptr++; 392 ptr = look(ptr,"function"); 393 return(ptr); 394 } 395 else 396 return(0); 397 } 398 399 /* if first 6 col. blank, return ptr to col. 7, 400 if blanks and then tab, return ptr after tab, 401 else return 0 (labelled statement, comment or continuation */ 402 403 char * 404 skiplab(p) 405 char *p; 406 { 407 char *ptr; 408 409 for (ptr = p; ptr < &p[6]; ptr++) { 410 if (*ptr == ' ') 411 continue; 412 if (*ptr == '\t') { 413 ptr++; 414 break; 415 } 416 return (0); 417 } 418 return (ptr); 419 } 420 421 /* return 0 if m doesn't match initial part of s; 422 otherwise return ptr to next char after m in s */ 423 424 char * 425 look(s, m) 426 char *s, *m; 427 { 428 char *sp, *mp; 429 430 sp = s; mp = m; 431 while (*mp) { 432 trim(sp); 433 if (*sp++ != *mp++) 434 return (0); 435 } 436 return (sp); 437 } 438