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