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. All advertising materials mentioning features or use of this software 17 * must display the following acknowledgement: 18 * This product includes software developed by the University of 19 * California, Berkeley and its contributors. 20 * 4. Neither the name of the University nor the names of its contributors 21 * may be used to endorse or promote products derived from this software 22 * without specific prior written permission. 23 * 24 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 25 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 26 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 27 * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 28 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 29 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 30 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 31 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 33 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 34 * SUCH DAMAGE. 35 */ 36 37 #include <sys/cdefs.h> 38 #ifndef lint 39 __COPYRIGHT("@(#) Copyright (c) 1983, 1993\n\ 40 The Regents of the University of California. All rights reserved.\n"); 41 #endif /* not lint */ 42 43 #ifndef lint 44 #if 0 45 static char sccsid[] = "from: @(#)fsplit.c 8.1 (Berkeley) 6/6/93"; 46 #elsej 47 __RCSID("$NetBSD: fsplit.c,v 1.5 1997/10/18 15:14:52 lukem Exp $"); 48 #endif 49 #endif /* not lint */ 50 51 #include <sys/types.h> 52 #include <sys/stat.h> 53 54 #include <ctype.h> 55 #include <stdio.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 char buf[BSZ]; 86 FILE *ifp; 87 char x[]="zzz000.f", 88 mainp[]="main000.f", 89 blkp[]="blkdta000.f"; 90 91 void badparms __P((void)); 92 char *functs __P((char *)); 93 int getline __P((void)); 94 void get_name __P((char *, int)); 95 int main __P((int, char **)); 96 int lend __P((void)); 97 int lname __P((char *)); 98 char *look __P((char *, char *)); 99 int saveit __P((char *)); 100 int scan_name __P((char *, char *)); 101 char *skiplab __P((char *)); 102 103 #define TRUE 1 104 #define FALSE 0 105 int extr = FALSE, 106 extrknt = -1, 107 extrfnd[100]; 108 char extrbuf[1000], 109 *extrnames[100]; 110 struct stat sbuf; 111 112 #define trim(p) while (*p == ' ' || *p == '\t') p++ 113 114 int 115 main(argc, argv) 116 int argc; 117 char **argv; 118 { 119 FILE *ofp; /* output file */ 120 int rv; /* 1 if got card in output file, 0 otherwise */ 121 char *ptr; 122 int nflag; /* 1 if got name of subprog., 0 otherwise */ 123 int retval, i; 124 char name[20], *extrptr = extrbuf; 125 126 /* scan -e options */ 127 while ( argc > 1 && argv[1][0] == '-' && argv[1][1] == 'e') { 128 extr = TRUE; 129 ptr = argv[1] + 2; 130 if(!*ptr) { 131 argc--; 132 argv++; 133 if(argc <= 1) badparms(); 134 ptr = argv[1]; 135 } 136 extrknt = extrknt + 1; 137 extrnames[extrknt] = extrptr; 138 extrfnd[extrknt] = FALSE; 139 while(*ptr) *extrptr++ = *ptr++; 140 *extrptr++ = 0; 141 argc--; 142 argv++; 143 } 144 145 if (argc > 2) 146 badparms(); 147 else if (argc == 2) { 148 if ((ifp = fopen(argv[1], "r")) == NULL) { 149 fprintf(stderr, "fsplit: cannot open %s\n", argv[1]); 150 exit(1); 151 } 152 } 153 else 154 ifp = stdin; 155 for(;;) { 156 /* look for a temp file that doesn't correspond to an existing file */ 157 get_name(x, 3); 158 ofp = fopen(x, "w"); 159 nflag = 0; 160 rv = 0; 161 while (getline() > 0) { 162 rv = 1; 163 fprintf(ofp, "%s", buf); 164 if (lend()) /* look for an 'end' statement */ 165 break; 166 if (nflag == 0) /* if no name yet, try and find one */ 167 nflag = lname(name); 168 } 169 fclose(ofp); 170 if (rv == 0) { /* no lines in file, forget the file */ 171 unlink(x); 172 retval = 0; 173 for ( i = 0; i <= extrknt; i++ ) 174 if(!extrfnd[i]) { 175 retval = 1; 176 fprintf( stderr, "fsplit: %s not found\n", 177 extrnames[i]); 178 } 179 exit( retval ); 180 } 181 if (nflag) { /* rename the file */ 182 if(saveit(name)) { 183 if (stat(name, &sbuf) < 0 ) { 184 link(x, name); 185 unlink(x); 186 printf("%s\n", name); 187 continue; 188 } else if (strcmp(name, x) == 0) { 189 printf("%s\n", x); 190 continue; 191 } 192 printf("%s already exists, put in %s\n", name, x); 193 continue; 194 } else 195 unlink(x); 196 continue; 197 } 198 if(!extr) 199 printf("%s\n", x); 200 else 201 unlink(x); 202 } 203 } 204 205 void 206 badparms() 207 { 208 fprintf(stderr, "fsplit: usage: fsplit [-e efile] ... [file] \n"); 209 exit(1); 210 } 211 212 int 213 saveit(name) 214 char *name; 215 { 216 int i; 217 char fname[50], 218 *fptr = fname; 219 220 if(!extr) return(1); 221 while(*name) *fptr++ = *name++; 222 *--fptr = 0; 223 *--fptr = 0; 224 for ( i=0 ; i<=extrknt; i++ ) 225 if( strcmp(fname, extrnames[i]) == 0 ) { 226 extrfnd[i] = TRUE; 227 return(1); 228 } 229 return(0); 230 } 231 232 void 233 get_name(name, letters) 234 char *name; 235 int letters; 236 { 237 char *ptr; 238 239 while (stat(name, &sbuf) >= 0) { 240 for (ptr = name + letters + 2; ptr >= name + letters; ptr--) { 241 (*ptr)++; 242 if (*ptr <= '9') 243 break; 244 *ptr = '0'; 245 } 246 if(ptr < name + letters) { 247 fprintf( stderr, "fsplit: ran out of file names\n"); 248 exit(1); 249 } 250 } 251 } 252 253 int 254 getline() 255 { 256 char *ptr; 257 258 for (ptr = buf; ptr < &buf[BSZ]; ) { 259 *ptr = getc(ifp); 260 if (feof(ifp)) 261 return (-1); 262 if (*ptr++ == '\n') { 263 *ptr = 0; 264 return (1); 265 } 266 } 267 while (getc(ifp) != '\n' && feof(ifp) == 0) ; 268 fprintf(stderr, "line truncated to %d characters\n", BSZ); 269 return (1); 270 } 271 272 /* return 1 for 'end' alone on card (up to col. 72), 0 otherwise */ 273 int 274 lend() 275 { 276 char *p; 277 278 if ((p = skiplab(buf)) == 0) 279 return (0); 280 trim(p); 281 if (*p != 'e' && *p != 'E') return(0); 282 p++; 283 trim(p); 284 if (*p != 'n' && *p != 'N') return(0); 285 p++; 286 trim(p); 287 if (*p != 'd' && *p != 'D') return(0); 288 p++; 289 trim(p); 290 if (p - buf >= 72 || *p == '\n') 291 return (1); 292 return (0); 293 } 294 295 /* check for keywords for subprograms 296 return 0 if comment card, 1 if found 297 name and put in arg string. invent name for unnamed 298 block datas and main programs. */ 299 300 int 301 lname(s) 302 char *s; 303 { 304 # define LINESIZE 80 305 char *ptr, *p; 306 char line[LINESIZE], *iptr = line; 307 308 /* first check for comment cards */ 309 if(buf[0] == 'c' || buf[0] == 'C' || buf[0] == '*') return(0); 310 ptr = buf; 311 while (*ptr == ' ' || *ptr == '\t') ptr++; 312 if(*ptr == '\n') return(0); 313 314 315 ptr = skiplab(buf); 316 if (ptr == 0) 317 return (0); 318 319 320 /* copy to buffer and converting to lower case */ 321 p = ptr; 322 while (*p && p <= &buf[71] ) { 323 *iptr = isupper(*p) ? tolower(*p) : *p; 324 iptr++; 325 p++; 326 } 327 *iptr = '\n'; 328 329 if ((ptr = look(line, "subroutine")) != 0 || 330 (ptr = look(line, "function")) != 0 || 331 (ptr = functs(line)) != 0) { 332 if(scan_name(s, ptr)) return(1); 333 strcpy( s, x); 334 } else if((ptr = look(line, "program")) != 0) { 335 if(scan_name(s, ptr)) return(1); 336 get_name( mainp, 4); 337 strcpy( s, mainp); 338 } else if((ptr = look(line, "blockdata")) != 0) { 339 if(scan_name(s, ptr)) return(1); 340 get_name( blkp, 6); 341 strcpy( s, blkp); 342 } else if((ptr = functs(line)) != 0) { 343 if(scan_name(s, ptr)) return(1); 344 strcpy( s, x); 345 } else { 346 get_name( mainp, 4); 347 strcpy( s, mainp); 348 } 349 return(1); 350 } 351 352 int 353 scan_name(s, ptr) 354 char *s, *ptr; 355 { 356 char *sptr; 357 358 /* scan off the name */ 359 trim(ptr); 360 sptr = s; 361 while (*ptr != '(' && *ptr != '\n') { 362 if (*ptr != ' ' && *ptr != '\t') 363 *sptr++ = *ptr; 364 ptr++; 365 } 366 367 if (sptr == s) return(0); 368 369 *sptr++ = '.'; 370 *sptr++ = 'f'; 371 *sptr++ = 0; 372 return(1); 373 } 374 375 char * 376 functs(p) 377 char *p; 378 { 379 char *ptr; 380 381 /* look for typed functions such as: real*8 function, 382 character*16 function, character*(*) function */ 383 384 if((ptr = look(p,"character")) != 0 || 385 (ptr = look(p,"logical")) != 0 || 386 (ptr = look(p,"real")) != 0 || 387 (ptr = look(p,"integer")) != 0 || 388 (ptr = look(p,"doubleprecision")) != 0 || 389 (ptr = look(p,"complex")) != 0 || 390 (ptr = look(p,"doublecomplex")) != 0 ) { 391 while ( *ptr == ' ' || *ptr == '\t' || *ptr == '*' 392 || (*ptr >= '0' && *ptr <= '9') 393 || *ptr == '(' || *ptr == ')') ptr++; 394 ptr = look(ptr,"function"); 395 return(ptr); 396 } 397 else 398 return(0); 399 } 400 401 /* if first 6 col. blank, return ptr to col. 7, 402 if blanks and then tab, return ptr after tab, 403 else return 0 (labelled statement, comment or continuation */ 404 405 char * 406 skiplab(p) 407 char *p; 408 { 409 char *ptr; 410 411 for (ptr = p; ptr < &p[6]; ptr++) { 412 if (*ptr == ' ') 413 continue; 414 if (*ptr == '\t') { 415 ptr++; 416 break; 417 } 418 return (0); 419 } 420 return (ptr); 421 } 422 423 /* return 0 if m doesn't match initial part of s; 424 otherwise return ptr to next char after m in s */ 425 426 char * 427 look(s, m) 428 char *s, *m; 429 { 430 char *sp, *mp; 431 432 sp = s; mp = m; 433 while (*mp) { 434 trim(sp); 435 if (*sp++ != *mp++) 436 return (0); 437 } 438 return (sp); 439 } 440