4.3BSD - /usr/src/usr.bin/f77/src/fsplit/fsplit.c

   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: }

Defined functions

Defined variables

Defined macros