1 /* 2 * Copyright (c) 1983 The Regents of the University of California. 3 * 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 char copyright[] = 13 "@(#) Copyright (c) 1983 The Regents of the University of California.\n\ 14 All rights reserved.\n"; 15 #endif /* not lint */ 16 17 #ifndef lint 18 static char sccsid[] = "@(#)fsplit.c 5.4 (Berkeley) 06/01/90"; 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 266 /* copy to buffer and converting to lower case */ 267 p = ptr; 268 while (*p && p <= &buf[71] ) { 269 *iptr = isupper(*p) ? tolower(*p) : *p; 270 iptr++; 271 p++; 272 } 273 *iptr = '\n'; 274 275 if ((ptr = look(line, "subroutine")) != 0 || 276 (ptr = look(line, "function")) != 0 || 277 (ptr = functs(line)) != 0) { 278 if(scan_name(s, ptr)) return(1); 279 strcpy( s, x); 280 } else if((ptr = look(line, "program")) != 0) { 281 if(scan_name(s, ptr)) return(1); 282 get_name( mainp, 4); 283 strcpy( s, mainp); 284 } else if((ptr = look(line, "blockdata")) != 0) { 285 if(scan_name(s, ptr)) return(1); 286 get_name( blkp, 6); 287 strcpy( s, blkp); 288 } else if((ptr = functs(line)) != 0) { 289 if(scan_name(s, ptr)) return(1); 290 strcpy( s, x); 291 } else { 292 get_name( mainp, 4); 293 strcpy( s, mainp); 294 } 295 return(1); 296 } 297 298 scan_name(s, ptr) 299 char *s, *ptr; 300 { 301 char *sptr; 302 303 /* scan off the name */ 304 trim(ptr); 305 sptr = s; 306 while (*ptr != '(' && *ptr != '\n') { 307 if (*ptr != ' ' && *ptr != '\t') 308 *sptr++ = *ptr; 309 ptr++; 310 } 311 312 if (sptr == s) return(0); 313 314 *sptr++ = '.'; 315 *sptr++ = 'f'; 316 *sptr++ = 0; 317 return(1); 318 } 319 320 char *functs(p) 321 char *p; 322 { 323 register char *ptr; 324 325 /* look for typed functions such as: real*8 function, 326 character*16 function, character*(*) function */ 327 328 if((ptr = look(p,"character")) != 0 || 329 (ptr = look(p,"logical")) != 0 || 330 (ptr = look(p,"real")) != 0 || 331 (ptr = look(p,"integer")) != 0 || 332 (ptr = look(p,"doubleprecision")) != 0 || 333 (ptr = look(p,"complex")) != 0 || 334 (ptr = look(p,"doublecomplex")) != 0 ) { 335 while ( *ptr == ' ' || *ptr == '\t' || *ptr == '*' 336 || (*ptr >= '0' && *ptr <= '9') 337 || *ptr == '(' || *ptr == ')') ptr++; 338 ptr = look(ptr,"function"); 339 return(ptr); 340 } 341 else 342 return(0); 343 } 344 345 /* if first 6 col. blank, return ptr to col. 7, 346 if blanks and then tab, return ptr after tab, 347 else return 0 (labelled statement, comment or continuation */ 348 char *skiplab(p) 349 char *p; 350 { 351 register char *ptr; 352 353 for (ptr = p; ptr < &p[6]; ptr++) { 354 if (*ptr == ' ') 355 continue; 356 if (*ptr == '\t') { 357 ptr++; 358 break; 359 } 360 return (0); 361 } 362 return (ptr); 363 } 364 365 /* return 0 if m doesn't match initial part of s; 366 otherwise return ptr to next char after m in s */ 367 char *look(s, m) 368 char *s, *m; 369 { 370 register char *sp, *mp; 371 372 sp = s; mp = m; 373 while (*mp) { 374 trim(sp); 375 if (*sp++ != *mp++) 376 return (0); 377 } 378 return (sp); 379 } 380