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