25 #include "pips_config.h"
67 #define isbegincomment(c) \
68 ((c)=='!' || (c)=='*' || (c)=='c' || (c)=='C' || (c)=='#')
69 #define issquote(c) ((c)=='\'')
70 #define isdquote(c) ((c)=='\"')
71 #define ishH(c) ((c)=='h' || (c)=='H')
72 #define char2int(c) ((int)((c)-'0'))
74 static char * hollerith_and_bangcomments(char *);
78 * Copyright (c) 1983 The Regents of the University of California.
79 * All rights reserved.
81 * This code is derived from software contributed to Berkeley by
82 * Asa Romberger and Jerry Berkman.
84 * Redistribution and use in source and binary forms, with or without
85 * modification, are permitted provided that the following conditions
87 * 1. Redistributions of source code must retain the above copyright
88 * notice, this list of conditions and the following disclaimer.
89 * 2. Redistributions in binary form must reproduce the above copyright
90 * notice, this list of conditions and the following disclaimer in the
91 * documentation and/or other materials provided with the distribution.
92 * 3. All advertising materials mentioning features or use of this software
93 * must display the following acknowledgement:
94 * This product includes software developed by the University of
95 * California, Berkeley and its contributors.
96 * 4. Neither the name of the University nor the names of its contributors
97 * may be used to endorse or promote products derived from this software
98 * without specific prior written permission.
100 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
101 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
102 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
103 * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
104 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
105 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
106 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
107 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
108 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
109 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
114 char fsplit_copyright[] =
115 "@(#) Copyright (c) 1983 The Regents of the University of California.\n\
116 All rights reserved.\n";
117 #endif /* not lint */
120 char fsplit_sccsid[] = "@(#)fsplit.c 5.5 (Berkeley) 3/12/91";
121 #endif /* not lint */
128 #include <sys/types.h>
129 #include <sys/stat.h>
132 * usage: fsplit [-e efile] ... [file]
134 * split single file containing source for several fortran programs
135 * and/or subprograms into files each containing one
137 * each separate file will be named using the corresponding subroutine,
138 * function, block data or program name if one is found; otherwise
139 * the name will be of the form mainNNN.f or blkdtaNNN.f .
140 * If a file of that name exists, it is saved in a name of the
142 * If -e option is used, then only those subprograms named in the -e
143 * option are split off; e.g.:
144 * fsplit -esub1 -e sub2 prog.f
145 * isolates sub1 and sub2 in sub1.f and sub2.f. The space
146 * after -e is optional.
148 * Modified Feb., 1983 by Jerry Berkman, Computing Services, U.C. Berkeley.
150 * - more function types: double complex, character*(*), etc.
152 * - instead of all unnamed going into zNNN.f, put mains in
153 * mainNNN.f, block datas in blkdtaNNN.f, dups in zzzNNN.f .
157 static char buf[BSZ];
159 static char *x, *mainp, *blkp;
163 static struct stat sbuf;
165 static char *look(), *skiplab(), *functs();
166 static int scan_name();
167 static void get_name();
169 #define trim(p) while (*p == ' ' || *p == '\t') p++
171 static char * full_name(char * dir, char * name)
173 char * full = (char*) malloc(sizeof(char)*(strlen(dir)+strlen(name)+2));
174 sprintf(full, "%s/%s", dir, name);
178 static void get_name(name)
183 while (stat(name, &sbuf) >= 0)
185 ptr = name + strlen(name) - 1;
186 while (!isdigit((int) *ptr--) && ptr>name);
187 for (ptr++; isdigit((int) *ptr) && ptr>name; ptr--) {
194 fprintf( stderr, "fsplit: ran out of file names\n");
200 static int current_line_number = 0;
202 /* getline does not handle continuations...
208 current_line_number++;
210 if (feof(ifp)) return -1;
212 for (ptr = buf; ptr < &buf[BSZ]; ) {
214 /* fix for the last line that may not have a \n.
215 * It is returned however and lend handles it correctly.
217 if (feof(ifp) || *ptr++ == '\n')
223 while (getc(ifp) != '\n' && feof(ifp) == 0) ;
224 fprintf(stderr, "line truncated to %d characters\n", BSZ);
228 static char * skip_comment_if_any(char * lines)
232 while (isbegincomment(lines[i]))
234 while (lines[i]!='\0' && lines[i]!='\n') i++;
235 if (lines[i]=='\n') i++;
241 /* return 1 for 'end' alone on card (up to col. 72), 0 otherwise */
244 register char *p, * lbuf;
247 lbuf = skip_comment_if_any(buf);
249 for (p=lbuf; p<&lbuf[6] && !tab; p++)
251 if (*p=='\0') return 0;
252 if (*p=='\t') tab=true;
255 if (!tab && (lbuf[5]!=' ' && lbuf[5]!='\t'))
256 return 0; /* a continuation */
259 if (*p != 'e' && *p != 'E') return(0);
262 if (*p != 'n' && *p != 'N') return(0);
265 if (*p != 'd' && *p != 'D') return(0);
268 if (p - buf >= 72 || *p == '\n' || *p == '\r' || *p == '\0')
273 static int implicit_program; /* FC */
274 static int implicit_blockdata_name; /* FC */
275 static int implicit_program_name; /* FC */
276 static int it_is_a_main; /* FC */
277 static int it_is_an_entry;
279 /* check for keywords for subprograms
280 return 0 if comment card, 1 if found
281 name and put in arg string. invent name for unnamed
282 block datas and main programs. */
283 static int lname(char * s, int look_for_entry)
285 register char *ptr, *p;
286 char line[LINESIZE], *iptr = line, * lbuf;
288 implicit_program = 0;
289 implicit_blockdata_name = 0;
290 implicit_program_name = 0;
294 lbuf = skip_comment_if_any(buf);
296 /* first check for comment cards */
297 if(isbegincomment(lbuf[0]))
300 while (*ptr == ' ' || *ptr == '\t') ptr++;
301 if(*ptr == '\n') return(0);
304 if (ptr == 0) return (0);
306 /* copy to buffer and converting to lower case */
308 while (*p && p <= &lbuf[71] ) {
309 *iptr = isupper((int) *p) ? tolower(*p) : *p;
315 if (look_for_entry) {
316 /* entry is looked for within a something... */
317 if ((ptr = look(line, "entry")) != 0)
318 if(scan_name(s, ptr))
321 if ((ptr = look(line, "subroutine")) != 0 ||
322 (ptr = look(line, "function")) != 0 ||
323 (ptr = functs(line)) != 0) {
324 if(!scan_name(s, ptr))
326 } else if((ptr = look(line, "program")) != 0) {
328 if(!scan_name(s, ptr)) {
329 implicit_program_name = 1;
333 } else if((ptr = look(line, "blockdata")) != 0) {
334 if(!scan_name(s, ptr)) {
335 implicit_blockdata_name = 1;
339 } else if((ptr = functs(line)) != 0) {
340 if(!scan_name(s, ptr))
343 implicit_program = 1;
353 #define allowed_first_char(c) \
354 (((c)>='a' && (c)<='z') || ((c)>='A' && (c)<='Z') || ((c)=='_'))
356 #define allowed_char(c) \
357 (allowed_first_char(c) || ((c)>='0' && (c)<='9'))
359 #define skippable_char(c) \
360 ((c)==' ' || (c)=='\t' || (c)=='\r')
362 static int scan_name(s, ptr)
367 /* scan off the name */
371 /* must have a valid first char. */
372 if (!allowed_first_char(*ptr)) return 0;
374 while (allowed_char(*ptr) || skippable_char(*ptr)) {
375 if (!skippable_char(*ptr))
380 if (sptr == s) return(0);
382 /* next char should be a ( or \n */
383 if (*ptr!='(' && *ptr!='\n') return 0;
391 static char *functs(p)
396 /* look for typed functions such as: real*8 function,
397 character*16 function, character*(*) function */
399 if((ptr = look(p,"character")) != 0 ||
400 (ptr = look(p,"logical")) != 0 ||
401 (ptr = look(p,"real")) != 0 ||
402 (ptr = look(p,"integer")) != 0 ||
403 (ptr = look(p,"doubleprecision")) != 0 ||
404 (ptr = look(p,"complex")) != 0 ||
405 (ptr = look(p,"doublecomplex")) != 0 ) {
406 while ( *ptr == ' ' || *ptr == '\t' || *ptr == '*'
407 || (*ptr >= '0' && *ptr <= '9')
408 || *ptr == '(' || *ptr == ')') ptr++;
409 ptr = look(ptr,"function");
416 /* if first 6 col. blank, return ptr to col. 7,
417 if blanks and then tab, return ptr after tab,
418 else return 0 (labelled statement, comment or continuation */
419 static char *skiplab(p)
424 for (ptr = p; ptr < &p[6]; ptr++) {
436 /* return 0 if m doesn't match initial part of s;
437 otherwise return ptr to next char after m in s */
438 static char *look(s, m)
441 register char *sp, *mp;
452 static void put_upper_from_slash_till_dot_or_end(char * what, FILE * where)
455 char * tmp = what+strlen(what);
456 while (tmp>what && *tmp!='/') tmp--;
457 if (what!=tmp) what=tmp+1;
459 while (*what && *what!='.') putc(toupper(*what++), where);
462 static void print_name(FILE * o, char * name, int n, int upper) /* FC */
464 name = name + strlen(name) - n - 2;
465 while (n-->0) putc(upper? toupper(*name++): *name++, o);
468 #define FREE_STRINGS \
469 if (main_list) free(main_list), main_list = NULL; \
470 if (x) free(x), x = NULL; \
471 if (mainp) free(mainp), mainp = NULL; \
472 if (blkp) free(blkp), blkp = NULL;
474 char * fsplit(char * dir_name, char * file_name, FILE * out)
476 FILE *ofp; /* output file */
477 int rv; /* 1 if got card in output file, 0 otherwise */
478 int nflag, /* 1 if got name of subprog., 0 otherwise */
480 /* ??? 20 -> 80 because not checked... smaller than a line is ok ? FC */
486 char * main_list = full_name(dir_name, MAIN_FILE_NAMES);
487 x = full_name(dir_name, "###000.f");
488 mainp = full_name(dir_name, "main000.f");
489 blkp = full_name(dir_name, "data000.f");
491 current_line_number = 0;
493 if ((ifp = fopen(file_name, "r")) == NULL) {
494 fprintf(stderr, "fsplit: cannot open %s\n", file_name);
496 return "cannot open file";
501 /* look for a temp file that doesn't correspond to an existing file */
505 fprintf(stderr, "%s %s -> %s\n", dir_name, file_name, x);
506 fprintf(stderr, "fopen(\"%s\", ...) failed\n", x);
526 nflag =
lname(name, 0), newname=nflag;
537 FILE * fm = fopen(main_list,
"a");
539 fprintf(stderr,
"fopen(\"%s\", ...) failed\n", main_list);
555 "! next line added by fsplit() in pips\n"
565 "! next line modified by fsplit() in pips\n"
579 if ((someentry && tmpname[0]) || (!someentry && name[0]))
582 (someentry? tmpname: name,
out);
597 fprintf(stderr,
"fclose(ofp) failed\n");
603 fprintf(stderr,
"fclose(ifp) failed\n");
610 if (strncmp(dir_name, name, strlen(dir_name))!=0)
616 if (strcmp(name,
x) == 0) {
619 else if (stat(name, &
sbuf) < 0 )
621 int ok = link(
x, name);
628 printf(
"%s already exists, put in %s\n", name,
x);
635 fprintf(stderr,
"fclose(ifp) failed\n");
639 return "bad fsplit() terminaison.";
664 if (!isspace((
int) *
line++))
670 "pips internal error: cannot process " \
671 "hollerith constants on continued lines (line %d)"
675 int i,j,initial, touched=0, bang=0;
676 char bangcomment[
BSZ];
678 bangcomment[0] =
'\0';
691 i = (
line[0]==
'\t')? 1: 6;
694 if (!
line[j])
return NULL;
696 if (isspace((
int)
line[i-1]))
701 while (
line[i] && initial<72)
709 if (isalpha((
int)
line[i]))
711 else if (!isalnum((
int)
line[i]) && !isspace((
int)
line[i])
723 while (
line[i] && initial<72
724 && (isdigit((
int)
line[i]) || isspace((
int)
line[i])))
726 if (isdigit((
int)
line[i]))
731 if (!
line[i] || initial>=72)
return NULL;
746 tmp[0] =
'\''; i++, initial++;
747 while (j<200 &&
line[i] && initial<72 &&
748 line[i]!=
'\n' && len>0)
753 tmp[j++] =
line[i++];
767 while (j<199 && len>0)
779 int ll = strlen(
line), shift = i-(ni+j+1);
782 for (k=0; i+k<=ll; k++)
785 for (k=ll-i; k>=0; k--)
792 line[ni+j]=tmp[j], j--;
800 strcpy(bangcomment,&
line[i]);
810 int len = strlen(
line);
815 for (i=len; i>=72; i--)
line[i+7] =
line[i];
827 strcpy(
line,bangcomment);
#define error(fun, msg)
NewGen interface with C3 type Psysteme for PIPS project.
void safe_unlink(const char *file_name)
Delete the given file.
int fprintf()
test sc_min : ce test s'appelle par : programme fichier1.data fichier2.data ...
static int line
FLEX_SCANNER.
static void put_upper_from_slash_till_dot_or_end(char *what, FILE *where)
static int lend()
return 1 for 'end' alone on card (up to col.
static int blank_line_p(char *line)
static char * hollerith_and_bangcomments(char *)
static int lname(char *s, int look_for_entry)
check for keywords for subprograms return 0 if comment card, 1 if found name and put in arg string.
static int in_squotes
ADDITION: basic Hollerith constants handling FC 11 Apr 1997.
static int it_is_an_entry
FC.
static int current_line_number
#define isbegincomment(c)
added macros
static void print_name(FILE *o, char *name, int n, int upper)
FC.
static int implicit_program_name
FC.
char * process_bang_comments_and_hollerith(FILE *in, FILE *out)
processing extracted for includes...
static int implicit_blockdata_name
FC.
static int it_is_a_main
FC.
static char * full_name(char *dir, char *name)
static int implicit_program
static int GetLine()
getline does not handle continuations...