usr.bin/fsplit/fsplit.c

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