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