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