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